;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;This program is distributed under the terms of the       ;;;
;;;GNU General Public License.                              ;;;
;;;Copyright (C) 2011 David Joseph Stith                    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;Converts INTEGER in VAL to big integer with undefined value
;;;given size in TEMP in tetras (preserved).
(: 'bigify_integer)
  (push TEMP)
  (test (~ #x1fff) TEMP)
  (jnzl 'error_overflow)
  (shl 2 TEMP)
  (and! #x0003ffff (@ VAL))
  (call 'insure_string_space)
  (shl 16 TEMP)
  (or! TEMP (@ VAL))
  (mov (@ 'freestring) TEMP)
  (mov TEMP (@ 4 VAL))
  (mov (@ esp) TEMP)
  (shl 2 TEMP)
  (add TEMP (@ 'freestring))
  (pop TEMP)
  (ret)

;;;Make copy of ARGL in ARGL 
;;;guaranteeing extra tetra of string space
(: 'duplicate_integer)
  (mov (@ ARGL) TEMP)
  (mov TEMP (@ FREE))
  (shr 18 TEMP)
  (test TEMP TEMP)
  (ifz
    (begin
      (mov (@ 4 ARGL) TEMP)
      (mov TEMP (@ 4 FREE))
      (mov FREE ARGL)
      (jmpl 'advance_free)))
  (inc TEMP) ;insure one extra tetra
  (test (~ #x1fff) TEMP)
  (jnzl 'error_overflow)
  (shl 2 TEMP)
  (call 'insure_string_space)
  (mov (@ ARGL) TEMP)
  (mov TEMP (@ FREE))
  (add #x40000 (@ FREE)) ;one extra tetra
  (jsl 'error_overflow)
  (shr 18 TEMP)
  (push UNEV)
  (mov (@ 4 ARGL) UNEV)
  (mov (@ 'freestring) ARGL)
  (mov ARGL (@ 4 FREE))
  (rep)(movs)
  (mov 0 (@ ARGL)) ;one extra tetra
  (add 4 ARGL)
  (mov ARGL (@ 'freestring))
  (mov FREE ARGL)
  (pop UNEV)
  (jmpl 'advance_free)

;;;Shift integer in ARGL left one bit in place.
;;;Return high tetra after shift in TEMP.
;;;ARGL not preserved.
(: 'shift_with_carry_left)
  (mov (@ ARGL) TEMP)
  (shr 18 TEMP)
  (ifz
    (begin
      (mov (@ 4 ARGL) TEMP)
      (clc)
      (rcl 1 TEMP)
      (mov TEMP (@ 4 ARGL))
      (ret)))
  (mov (@ 4 ARGL) ARGL)
  (clc)
  (jmp 'shift_with_carry_left_big_loop_begin)
(: 'shift_with_carry_left_big_loop)
  (add 4 ARGL)
  (popf)
(: 'shift_with_carry_left_big_loop_begin)
  (rcl 1 (@ ARGL))
  (pushf)
  (loop 'shift_with_carry_left_big_loop)
  (popf)
  (ifc
    (begin
      (add 4 ARGL)
      (mov 1 (@ ARGL))))
  (mov (@ ARGL) TEMP)
  (mov 0 ARGL)
  (ret)

;;;Shift integer in VAL right one bit in place.
;;;VAL preserved.
(: 'shift_right)
  (mov (@ VAL) TEMP)
  (shr 18 TEMP)
  (ifz
    (begin
      (shr 1 (@ 4 VAL))
      (ret)))
  (mov (@ 4 VAL) ARGL)
  (lea (@ -4 ARGL TEMP 2) ARGL)
  (cmp 1 (@ ARGL))
  (ife (sub #x40000 (@ VAL)))
  (clc)
  (jmp 'shift_right_big_loop_begin)
(: 'shift_right_big_loop)
  (pushf)
  (sub 4 ARGL)
  (popf)
(: 'shift_right_big_loop_begin)
  (rcr 1 (@ ARGL))
  (loop 'shift_right_big_loop)
  (clear ARGL)
  (ret)
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Integer Math Primitives ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "+")
  (mov (object INTEGER 0) VAL)
  (call 'advance_free)
(: 'add_loop)
  (test ARGL ARGL)
  (jzl 'add_end)
  (get-number-exactness VAL)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_add)
  (xor (@ VAL) TEMP)
  (test #x00020000 TEMP) ;sign-bit
  (jnz 'add_unlike)
  (call 'add_like)
  (jmp 'add_next)
(: 'add_unlike)
  (call 'sub_like)
(: 'add_next)
  (mov (@ 4 ARGL) ARGL)
  (jmpl 'add_loop)

(: 'add_like)
  (test #xfffc0000 (@ EXP))
  (jnzl 'add_like_big)
  (test #xfffc0000 (@ VAL))
  (jnzl 'add_like_big)
  (mov (@ 4 EXP) EXP) ;addend data first and only tetra
  (clc)
  (adc EXP (@ 4 VAL))
  (jncl 'add_end)
  (clear EXP)
  (push (@ 4 VAL))
  (mov 2 TEMP)
  (call 'bigify_integer)
  (pop EXP)
  (mov (@ 4 VAL) TEMP)
  (mov EXP (@ TEMP))
  (mov 1 (@ 4 TEMP))
(: 'add_end)
  (clear EXP)
  (ret)

(: 'add_like_big)
  (mov VAL UNEV)
  (mov (@ VAL) TEMP)
  (mov TEMP (@ FREE))
  (mov (@ EXP) TEMP)
  (and! (~ #x20000) TEMP)
  (or! TEMP (@ FREE))
  (and! #x3ffff (@ FREE))
  (cmp (@ UNEV) TEMP)
  (jle 'add_like_big_canonical)
  (mov EXP UNEV)
  (mov VAL EXP)
(: 'add_like_big_canonical) ;UNEV longer than EXP
  (mov FREE VAL)
  (call 'advance_free)
  (mov (@ UNEV) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
  (call 'bigify_integer)
  (pusha)
  (mov esp (@ 'io_file))
  (mov (@ EXP) TEMP)
  (shr 18 TEMP)
  (test TEMP TEMP)
  (jnz 'add_like_big_src)
  (push 1)
  (lea (@ 4 EXP) TEMP)
  (push TEMP)
  (jmp 'add_like_big_continue)
(: 'add_like_big_src)
  (push TEMP)
  (push (@ 4 EXP))
(: 'add_like_big_continue)
  (mov (@ 'src1size) TEMP)
  (push TEMP)
  (push (@ 4 UNEV))
  (push (@ 4 VAL))
  (call 'calln_mpn_add)
  (test eax eax)
  (jz 'add_like_big_no_carry)
  (mov (@ 'io_file) esp)
  (popa)
  (mov (@ VAL) TEMP)
  (add #x40000 (@ VAL))
  (jsl 'error_overflow)
  (shr 18 TEMP)
  (shl 2 TEMP)
  (add (@ 4 VAL) TEMP)
  (mov 1 (@ TEMP))
  (add 4 (@ 'freestring))
  (ret)
(: 'add_like_big_no_carry)
  (mov (@ 'io_file) esp)
  (popa)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "-")
  (insure-more-args ARGL)
  (mov (@ ARGL) EXP)
  (test EXP EXP)
  (jzl 'error_expected_number)
  (mov (@ EXP) TEMP)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_subtract_first)
  (and! #x3ffff TEMP)
  (mov (object TEMP 0) VAL)
  (call 'advance_free)
  (mov (@ 4 ARGL) ARGL)
  (test ARGL ARGL)
  (jz 'sub_like)
  (call 'add_like)
(: 'sub_loop)
  (get-number-exactness VAL)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_subtract)
  (xor (@ VAL) TEMP)
  (test #x00020000 TEMP) ;sign-bit
  (jnz 'sub_unlike)
  (call 'sub_like)
  (jmp 'sub_next)
(: 'sub_unlike)
  (call 'add_like)
(: 'sub_next)
  (mov (@ 4 ARGL) ARGL)
  (test ARGL ARGL)
  (jnz 'sub_loop)
  (ret)

(: 'sub_like)
  (test #xfffc0000 (@ EXP))
  (jnzl 'sub_like_big)
  (test #xfffc0000 (@ VAL))
  (jnzl 'sub_like_big)
  (mov (@ 4 EXP) EXP) ;subtrahend data first and only tetra
  (clc)
  (sbb EXP (@ 4 VAL))
  (jnc 'sub_like_same_sign)
  (xor #x00020000 (@ VAL))
  (neg (@ 4 VAL))
  (clc)
(: 'sub_like_same_sign)
  (clear EXP)
  (cmp 0 (@ 4 VAL))
  (jne 'sub_end)
  (and! #xffff (@ VAL))
(: 'sub_end)
  (ret)

(: 'sub_like_big)
  (mov VAL UNEV)
  (mov (@ VAL) TEMP)
  (and! #x30000 TEMP)
  (mov TEMP (@ FREE))
  (mov (@ EXP) TEMP)
  (and! (~ #x20000) TEMP)
  (or! TEMP (@ FREE))
  (cmp (@ UNEV) TEMP)
  (jle 'sub_like_big_canonical)
  (mov EXP UNEV)
  (mov VAL EXP)
  (xor #x20000 (@ FREE))
(: 'sub_like_big_canonical) ;UNEV longer than EXP
  (mov FREE VAL)
  (add 8 FREE)
  (mov (@ UNEV) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
  (call 'bigify_integer)
  (pusha)
  (mov esp (@ 'io_file))
  (mov (@ EXP) TEMP)
  (shr 18 TEMP)
  (test TEMP TEMP)
  (jnz 'sub_like_big_src)
  (push 1)
  (lea (@ 4 EXP) TEMP)
  (push TEMP)
  (jmp 'sub_like_big_continue)
(: 'sub_like_big_src)
  (push TEMP)
  (push (@ 4 EXP))
(: 'sub_like_big_continue)
  (mov (@ 'src1size) TEMP)
  (push TEMP)
  (push (@ 4 UNEV))
  (push (@ 4 VAL))
  (call 'calln_mpn_sub)
  (test eax eax)
  (jz 'sub_like_big_no_borrow)
  (mov (@ 'io_file) esp)
  (popa)
  (xor #x20000 (@ VAL))
  (mov (@ 4 VAL) EXP)
  (mov (@ VAL) TEMP)
  (shr 18 TEMP)
(: 'sub_like_reverse_loop)
  (not! (@ -4 EXP TEMP 2))
  (loop 'sub_like_reverse_loop)
  (mov (@ 4 VAL) EXP)
  (clc)
  (adc 1 (@ EXP))
  (jnc 'big_simplify)
(: 'sub_like_reverse_negate_loop)
  (add 4 EXP)
  (adc 0 (@ EXP))
  (jc 'sub_like_reverse_negate_loop)
  (jmp 'big_simplify)
(: 'sub_like_big_no_borrow)
  (mov (@ 'io_file) esp)
  (popa)

(: 'big_simplify)
  (mov (@ 4 VAL) EXP)
  (mov (@ VAL) TEMP)
  (shr 18 TEMP)
(: 'big_simplify_loop)
  (cmp 0 (@ -4 EXP TEMP 2))
  (jnz 'big_shrunk)
  (sub #x40000 (@ VAL))
  (loop 'big_simplify_loop)
  (mov 0 (@ 4 VAL))
  (and! #x1ffff (@ VAL))
(: 'big_end)
  (clear EXP)
  (ret)
(: 'big_shrunk)
  (cmp 1 TEMP)
  (jne 'big_end)
  (sub #x40000 (@ VAL))
  (mov (@ EXP) TEMP)
  (mov TEMP (@ 4 VAL))
  (clear EXP)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "*")
  (mov (object INTEGER 1) VAL)
  (call 'advance_free)
(: 'mult_loop)
  (test ARGL ARGL)
  (jzl 'mult_end)
  (get-number-exactness VAL)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_multiply)
  (cmp 0 (@ 4 EXP))
  (jnz 'mult_nonzero)
;;we are multiplying by a zero with header TEMP
;;therefore the result can be as exact as the zero is.
;;(and as positive as well)
  (mov TEMP (@ VAL))
  (mov 0 (@ 4 VAL))
(: 'mult_end)
  (ret)
(: 'mult_nonzero)
  (test #xfffc0000 (@ EXP))
  (jnzl 'mult_big)
  (test #xfffc0000 (@ VAL))
  (jnzl 'mult_big)
  (mov (@ 4 EXP) EXP) ;multiplier data first and only tetra
  (mov VAL UNEV)
  (mov (@ 4 VAL) VAL)
  (mul EXP)
  (mov VAL (@ 4 UNEV))
  (mov UNEV VAL)
  (jnol 'mult_sign)
  (push TEMP)
  (push EXP)
  (clear EXP)
  (mov 8 TEMP)
  (call 'insure_string_space)
  (or! #x00080000 (@ VAL))
  (mov (@ 'freestring) TEMP)
  (mov (@ 4 VAL) EXP)
  (mov TEMP (@ 4 VAL))
  (mov EXP (@ TEMP))
  (add 4 TEMP)
  (pop EXP)
  (mov EXP (@ TEMP))
  (add 4 TEMP)
  (mov TEMP (@ 'freestring))
  (clear EXP)
  (pop TEMP)
(: 'mult_sign)
  (xor (@ VAL) TEMP)
  (test #x00020000 TEMP) ;sign-bit
  (jz 'mult_like)
  (or! #x00020000 (@ VAL))
  (jmp 'mult_next)
(: 'mult_like)
  (and! (~ #x00020000) (@ VAL))
(: 'mult_next)
  (mov (@ 4 ARGL) ARGL)
  (jmpl 'mult_loop)

(: 'mult_big)
  (mov VAL UNEV)
  (push (@ UNEV))
  (mov (@ VAL) TEMP)
  (and! #x10000 TEMP)
  (or! (@ EXP) TEMP)
  (mov TEMP (@ FREE))
  (cmp (@ UNEV) TEMP)
  (jl 'mult_big_canonical)
  (mov EXP UNEV)
  (mov VAL EXP)
(: 'mult_big_canonical) ;UNEV longer than EXP
  (mov FREE VAL)
  (add 8 FREE)
  (mov (@ UNEV) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
  (mov (@ EXP) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src2size))
  (test TEMP TEMP)
  (jnz 'mult_big_exp)
  (inc TEMP)
(: 'mult_big_exp)
  (add (@ 'src1size) TEMP)
  (call 'bigify_integer)
  (pusha)
  (mov esp (@ 'io_file))
  (mov (@ 'src2size) TEMP)
  (test TEMP TEMP)
  (jnz 'mult_big_src)
  (push 1)
  (lea (@ 4 EXP) TEMP)
  (push TEMP)
  (jmp 'mult_continue)
(: 'mult_big_src)
  (push TEMP)
  (push (@ 4 EXP))
(: 'mult_continue)
  (mov (@ 'src1size) TEMP)
  (push TEMP)
  (push (@ 4 UNEV))
  (push (@ 4 VAL))
  (call 'calln_mpn_mul)
  (mov (@ 'io_file) esp)
  (popa)
  (call 'big_simplify)
  (pop TEMP)
  (jmpl 'mult_sign)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "/")
  (insure-more-args ARGL)
  (call 'get_integer_exactness)
  (mov (@ 4 ARGL) ARGL)
  (insure-one-last-arg ARGL)
  (mov (@ 4 EXP) VAL)
  (mov (object TEMP VAL) VAL) ;VAL is numerator
  (call 'advance_free)
  (mov INTEGER (@ FREE))
  (get-integer-exactness VAL) ;EXP is denominator
  (or! TEMP (@ FREE))
  (mov (@ 4 EXP) TEMP)
  (mov TEMP (@ 4 FREE))
  (mov FREE EXP)
  (call 'advance_free)
  (test #x20000 (@ EXP))
  (jz 'make_rational_simplify)
  (xor #x20000 (@ EXP))
  (xor #x20000 (@ VAL))
(: 'make_rational_simplify)
  (test #xfffc0000 (@ EXP))
  (jnz 'make_rational_end)
  (cmp 1 (@ 4 EXP))
  (jne 'make_rational_end)
  (ret)
(: 'make_rational_end)
  (mov (object VAL EXP) EXP)
  (call 'advance_free)
  (mov (@ VAL) TEMP)
  (and! #x30000 TEMP)
  (or! RATIONAL TEMP)
  (mov TEMP (@ FREE))
  (mov EXP (@ 4 FREE))
  (mov FREE VAL)
  (jmpl 'advance_free)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "quotient")
  (insure-more-args ARGL)
  (call 'get_integer_exactness)
  (and! #x3ffff TEMP)
  (mov TEMP (@ FREE))
  (mov 0 (@ 4 FREE))
  (mov EXP VAL)
  (mov (@ 4 ARGL) ARGL)
  (insure-one-last-arg ARGL)
  (call 'get_integer_exactness)
  (and! #x00020000 TEMP)
  (xor TEMP (@ FREE))
  (test #xfffc0000 (@ VAL))
  (jnzl 'quotient_big)
  (test #xfffc0000 (@ EXP))
  (jnzl 'quotient_end)
  (mov (@ 4 VAL) VAL)
  (mov (@ 4 EXP) TEMP)
  (clear EXP)
  (test TEMP TEMP)
  (jzl 'error_divide_by_zero)
  (div TEMP)
  (mov VAL (@ 4 FREE))
(: 'quotient_end)
  (mov FREE VAL)
  (cmp 0 (@ 4 VAL))
  (jne 'quotient_keep_sign)
  (and! #xffff (@ VAL))
(: 'quotient_keep_sign)
  (clear EXP)
  (jmpl 'advance_free)

(: 'quotient_big)
  (mov VAL UNEV) ;dividend
  (mov (@ EXP) TEMP) ;divisor
  (shr 18 TEMP)
  (mov TEMP (@ 'src2size))
  (mov (@ UNEV) TEMP) ;dividend
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
  (cmp (@ 'src2size) TEMP)
  (jb 'quotient_end)
  (ja 'quotient_big_start)
  (mov EXP (@ 'io_file))
  (mov (@ 4 EXP) EXP)
(: 'quotient_big_compare_loop)
  (mov (@ 4 UNEV) VAL)
  (mov (@ -4 VAL TEMP 2) VAL)
  (cmp (@ -4 EXP TEMP 2) VAL)
  (jb 'quotient_end)
  (ja 'quotient_big_ordered)
  (loop 'quotient_big_compare_loop)
  ;;absolute value of dividend and divisor are equal
  (mov 1 (@ 4 FREE))
  (mov (@ 'io_file) TEMP)
  (mov (@ TEMP) TEMP)
  (and! #x20000 TEMP)
  (xor TEMP (@ FREE))
  (jmpl 'quotient_end)
(: 'quotient_big_ordered)
  (mov (@ 'io_file) EXP)
(: 'quotient_big_start)
  (mov FREE VAL)
  (call 'advance_free)
  (call 'divrem)
  (cmp 0 (@ 'src1size)) ;high bits
  (jne 'quotient_big_no_shrink)
  (sub #x40000 (@ VAL))
  (jmpl 'big_simplify)
(: 'quotient_big_no_shrink)
  (mov (@ VAL) TEMP)
  (shr 18 TEMP)
  (mov (@ 'src1size) UNEV)
  (mov (@ 4 VAL) ARGL)
  (mov UNEV (@ -4 ARGL TEMP 2))
  (clear UNEV ARGL)
  (jmpl 'big_simplify)

;;;Divide UNEV by EXP.
;;;VAL must be an overwritable INTEGER.
;;;Quotient into VAL but High tetra in (@ 'src1size).
;;;Remainder in lower portion of UNEV left shifted (@ 'bytes_io) places.
(: 'divrem)
  (mov UNEV ARGL)
  (call 'duplicate_integer)
  (mov ARGL UNEV)
  (mov (@ 'src2size) TEMP)
  (test TEMP TEMP)
  (jz 'quotient_big_small_test_high_bit)
  (dec TEMP)
  (shl 2 TEMP)
  (add (@ 4 EXP) TEMP)
  (mov (@ TEMP) TEMP)
  (jmp 'quotient_big_test_high_bit)
(: 'quotient_big_small_test_high_bit)
  (mov (@ 4 EXP) TEMP)
  (test TEMP TEMP)
  (jzl 'error_divide_by_zero)
(: 'quotient_big_test_high_bit)
  (mov 0 (@ 'bytes_io))
  (test TEMP TEMP)
  (jsl 'quotient_big_normalized)
  (mov EXP ARGL)
  (call 'duplicate_integer)
  (mov ARGL EXP)
  (cmp 0 (@ 'src2size))
  (je 'quotient_big_normalize_loop)
  (sub #x40000 (@ EXP)) ;remove extra tetra
(: 'quotient_big_normalize_loop)
  (inc (@ 'bytes_io))
  (mov UNEV ARGL)
  (call 'shift_with_carry_left)
  (cmp 1 TEMP)
  (ife (inc (@ 'src1size))) ;for extra tetra
  (mov EXP ARGL)
  (call 'shift_with_carry_left)
  (test TEMP TEMP)
  (jns 'quotient_big_normalize_loop)
(: 'quotient_big_normalized)
  (mov (@ 'src1size) TEMP)
  (cmp 0 (@ 'src2size))
  (je 'quotient_big_noinc)
  (inc TEMP)
(: 'quotient_big_noinc)
  (sub (@ 'src2size) TEMP)
  (call 'bigify_integer)
  (pusha)
  (mov esp (@ 'io_file))
  (mov (@ 'src2size) TEMP)
  (test TEMP TEMP)
  (jz 'quotient_big_small)
  (push TEMP)
  (push (@ 4 EXP))
  (jmp 'quotient_big_continue)
(: 'quotient_big_small)
  (push 1)
  (push EXP)
  (add 4 (@ esp))
(: 'quotient_big_continue)
  (push (@ 'src1size))
  (push (@ 4 UNEV))
  (push 0)
  (push (@ 4 VAL))
  (call 'calln_mpn_divrem)
  (mov (@ 'io_file) esp)
  (mov VAL (@ 'src1size)) ;high bits
  (popa)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "remainder")
  (insure-more-args ARGL)
  (call 'get_integer_exactness)
  (and! #x3ffff TEMP)
  (mov TEMP (@ FREE))
  (mov 0 (@ 4 FREE))
  (mov EXP VAL)
  (mov (@ 4 ARGL) ARGL)
  (insure-one-last-arg ARGL)
  (call 'get_integer_exactness)
  (test #xfffc0000 (@ VAL))
  (jnzl 'remainder_big)
  (test #xfffc0000 (@ EXP))
  (jnzl 'remainder_end)
  (mov (@ 4 VAL) VAL)
  (mov (@ 4 EXP) TEMP)
  (clear EXP)
  (test TEMP TEMP)
  (jzl 'error_divide_by_zero)
  (div TEMP)
  (mov EXP (@ 4 FREE))
  (test EXP EXP)
  (jnz 'remainder_result)
(: 'remainder_abs_result)
  (and! (~ #x20000) (@ FREE))
(: 'remainder_result)
  (mov FREE VAL)
  (clear EXP)
  (jmpl 'advance_free)
(: 'remainder_end)
  (ret)

(: 'remainder_big)
  (mov VAL UNEV) ;dividend
  (mov (@ EXP) TEMP) ;divisor
  (shr 18 TEMP)
  (mov TEMP (@ 'src2size))
  (mov (@ UNEV) TEMP) ;dividend
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
  (cmp (@ 'src2size) TEMP)
  (jl 'remainder_end)
  (jg 'remainder_big_start)
  (mov EXP (@ 'io_file))
  (mov (@ 4 EXP) EXP)
(: 'remainder_big_compare_loop)
  (mov (@ 4 UNEV) VAL)
  (mov (@ -4 VAL TEMP 2) VAL)
  (cmp (@ -4 EXP TEMP 2) VAL)
  (jl 'remainder_end)
  (jg 'remainder_big_ordered)
  (loop 'remainder_big_compare_loop)
  ;;absolute value of dividend and divisor are equal
  (mov 0 (@ 4 FREE))
  (jmp 'remainder_abs_result)
(: 'remainder_big_ordered)
  (mov (@ 'io_file) EXP)
(: 'remainder_big_start)
  (mov FREE VAL)
  (call 'advance_free)
  (call 'divrem)
  (mov (@ 4 UNEV) TEMP)
  (mov TEMP (@ 4 VAL))
  (and! #x3ffff (@ VAL))
  (mov (@ 'src2size) TEMP)
  (test TEMP TEMP)
  (jnz 'remainder_shift)
  (inc TEMP)
(: 'remainder_shift)
  (shl 18 TEMP)
  (or! TEMP (@ VAL))
  (cmp 0 (@ 'bytes_io))
  (jel 'big_simplify)
  (call 'shift_right)
  (dec (@ 'bytes_io))
  (jmp 'remainder_shift)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "modulo")
  (save ARGL)
  (call 'prim_remainder)
  (restore ARGL)
  (cmp INTEGER (@ VAL))
  (jne 'modulo_normalize)
  (cmp 0 (@ 4 VAL))
  (je 'modulo_remainder)
(: 'modulo_normalize)
  (mov (@ 4 ARGL) ARGL)
  (mov (@ ARGL) EXP)
  (mov (@ VAL) TEMP)
  (xor (@ EXP) TEMP)
  (test #x00020000 TEMP)
  (jz 'modulo_remainder)
  (mov (object VAL ARGL) ARGL)
  (call 'advance_free)
  (jmpl 'prim_+)
(: 'modulo_remainder)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "positive?")
  (call 'get_last_number)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_positive)
(: 'integer_positive)
  (cmp 0 (@ 4 VAL))
  (je 'integer_not_positive)
  (test #x00020000 TEMP)
  (jzl 'return_true)
(: 'integer_not_positive)
  (return-false)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "negative?")
  (call 'get_last_number)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_negative)
(: 'integer_negative)
  (test #x00020000 TEMP)
  (jnzl 'return_true)
  (return-false)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "odd?")
  (insure-one-last-arg ARGL)
  (call 'get_integer_exactness)
  (test #xfffc0000 (@ EXP))
  (jnz 'odd_big)
  (test 1 (@ 4 EXP))
  (jzl 'return_false)
  (return-true)
(: 'odd_big)
  (mov (@ 4 EXP) TEMP)
  (test 1 (@ TEMP))
  (jzl 'return_false)
  (return-true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "even?")
  (insure-one-last-arg ARGL)
  (call 'get_integer_exactness)
  (test #xfffc0000 (@ EXP))
  (jnz 'even_big)
  (test 1 (@ 4 EXP))
  (jnzl 'return_false)
  (return-true)
(: 'even_big)
  (mov (@ 4 EXP) TEMP)
  (test 1 (@ TEMP))
  (jnzl 'return_false)
  (return-true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'abs_negate)
  (mov (@ 4 EXP) VAL)
  (xor #x00020000 TEMP)
  (mov TEMP (@ FREE))
  (mov VAL (@ 4 FREE))
  (mov FREE VAL)
  (jmpl 'advance_free)

(new-primitive "abs")
  (insure-one-last-arg ARGL)
  (mov INTEGER (@ FREE))
  (get-number-exactness FREE)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_abs)
  (test #x00020000 (@ EXP))
  (jnz 'abs_negate)
  (mov EXP VAL)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'return_zero)
  (mov (object INTEGER 0) VAL)
  (jmpl 'advance_free)

(new-primitive "gcd")
  (test ARGL ARGL)
  (jz 'return_zero)
  (call 'get_integer_exactness)
  (and! (~ #x20000) TEMP)
  (mov TEMP (@ FREE))
  (mov (@ 4 EXP) VAL)
  (mov VAL (@ 4 FREE))
  (mov FREE VAL)
  (call 'advance_free)
(: 'prim_gcd_next)
  (mov (@ 4 ARGL) ARGL)
  (test ARGL ARGL)
  (jz 'prim_gcd_end)
  (get-integer-exactness VAL)
  (test #xfffc0000 TEMP)
  (jnzl 'prim_gcd_big)
  (test #xfffc0000 (@ VAL))
  (jnzl 'prim_gcd_big)
  (mov (@ 4 EXP) TEMP)
  (mov VAL UNEV)
  (mov (@ 4 VAL) VAL)
  (jmp 'prim_gcd_loop_begin)

(: 'prim_gcd_loop)
  (clear EXP)
  (div TEMP)
  (mov TEMP VAL)
  (mov EXP TEMP)
(: 'prim_gcd_loop_begin)
  (test TEMP TEMP)
  (jnz 'prim_gcd_loop)

  (mov VAL (@ 4 UNEV))
  (mov UNEV VAL)
  (jmp 'prim_gcd_next)

(: 'prim_gcd_end)
  (clear EXP)
  (ret)

(: 'prim_gcd_big)
  (save ARGL) ;for safe keeping
  (mov (@ VAL) TEMP)
  (mov TEMP (@ FREE))
  (mov VAL UNEV)
  (mov (@ EXP) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size)) ;EXP size
  (mov (@ UNEV) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src2size)) ;UNEV size
  (mov EXP (@ 'io_file))
  (cmp (@ 'src1size) TEMP)
  (jg 'gcd_big_swap)
  (jl 'gcd_big_start)
  (mov (@ 4 EXP) EXP)
  (mov (@ 4 UNEV) VAL)
  (mov (@ -4 VAL TEMP 2) VAL)
  (cmp (@ -4 EXP TEMP 2) VAL)
  (jbe 'gcd_big_ordered)
(: 'gcd_big_swap)
  (mov UNEV EXP)
  (mov (@ 'src2size) UNEV)
  (mov (@ 'src1size) TEMP)
  (mov TEMP (@ 'src2size))
  (mov UNEV (@ 'src1size))
  (mov (@ 'io_file) UNEV)
  (jmp 'gcd_big_start)
(: 'gcd_big_ordered)
  (mov (@ 'io_file) EXP)
(: 'gcd_big_start)
  (mov FREE VAL)
  (call 'advance_free)
  (mov (@ 'src2size) TEMP)
  (test TEMP TEMP)
  (ifz (inc TEMP))
  (call 'bigify_integer)
  (mov UNEV ARGL)
  (call 'duplicate_integer)
  (mov ARGL UNEV)
  (test #xfffc0000 (@ UNEV))
  (ifnz (sub #x40000 (@ UNEV))) ;remove extra tetra
  (mov EXP ARGL)
  (call 'duplicate_integer)
  (mov ARGL EXP)
  (sub #x40000 (@ EXP)) ;remove extra tetra
  (mov 0 (@ 'bytes_io))
  (mov (@ 4 UNEV) TEMP)
  (cmp 0 (@ 'src2size))
  (ife
    (begin
      (test TEMP TEMP)
      (ifz
        (begin
          (mov EXP VAL)
          (restore ARGL)
          (jmpl 'prim_gcd_next))))
    (mov (@ TEMP) TEMP))
  (test #x01 TEMP)
  (jnz 'gcd_big_normalized)
  (push VAL)
(: 'gcd_big_normalize_loop)
  (mov (@ 4 EXP) TEMP)
  (test #x01 (@ TEMP))
  (ifz
    (begin
      (mov EXP VAL)
      (call 'shift_right)
      (inc (@ 'bytes_io))
      (mov UNEV VAL)
      (call 'shift_right)
      (mov (@ 4 VAL) TEMP)
      (cmp 0 (@ 'src2size))
      (ifne (mov (@ TEMP) TEMP))
      (test #x01 TEMP)
      (jz 'gcd_big_normalize_loop))
    (begin
      (cmp 0 (@ 'src2size))
      (ife
        (begin
         (: 'gcd_big_make_odd_small_loop)
          (shr 1 (@ 4 UNEV))
          (test #x01 (@ 4 UNEV))
          (jz 'gcd_big_make_odd_small_loop))
        (begin
         (: 'gcd_big_make_odd_big_loop)
          (mov UNEV VAL)
          (call 'shift_right)
          (mov (@ 4 VAL) TEMP)
          (mov (@ TEMP) TEMP)
          (test #x01 TEMP)
          (jz 'gcd_big_make_odd_big_loop)))))
  (mov (@ EXP) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
  (mov (@ UNEV) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src2size))
  (pop VAL)
(: 'gcd_big_normalized)
  (pusha)
  (mov esp (@ 'io_file))
  (mov (@ 'src2size) TEMP)
  (test TEMP TEMP)
  (ifnz
    (begin
      (push TEMP)
      (push (@ 4 UNEV)))
    (begin
      (push 1)
      (push UNEV)
      (add 4 (@ esp))))
  (push (@ 'src1size))
  (push (@ 4 EXP))
  (push (@ 4 VAL))
  (call 'calln_mpn_gcd)
  (mov VAL (@ 'src2size)) ;size of result
  (mov (@ 'io_file) esp)
  (popa)
  (and! #x3ffff (@ VAL))
  (mov (@ 'src2size) TEMP)
  (shl 18 TEMP)
  (or! TEMP (@ VAL))
  (cmp 0 (@ 'bytes_io))
  (ifnz
    (begin
     (: 'gcd_shift_result_loop)
      (mov VAL ARGL)
      (call 'shift_with_carry_left)
      (cmp 1 TEMP)
      (ife
        (begin
          (add #x40000 (@ VAL))
          (jsl 'error_overflow)))
      (dec (@ 'bytes_io))
      (jnz 'gcd_shift_result_loop)))
  (restore ARGL)
  (call 'big_simplify)
  (jmpl 'prim_gcd_next)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "min")
  (insure-more-args ARGL)
  (mov INTEGER (@ FREE))
  (get-number-exactness FREE)
  (mov EXP VAL) ;min thus far
  (mov (@ 4 ARGL) ARGL)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_min_first)
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
(: 'min_loop)
  (test ARGL ARGL)
  (jzl 'min_max_end)
  (get-number-exactness FREE)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_min)
  (test #x00020000 (@ EXP))
  (jnz 'min_negative)
  (test #x00020000 (@ VAL))
  (jnz 'min_next)
  (shr 18 TEMP)
  (cmp (@ 'src1size) TEMP)
  (jb 'min_less)
  (ja 'min_next)
  (jecxz 'min_simple)
  (push EXP)
  (push VAL)
  (mov (@ 4 EXP) EXP)
  (mov (@ 4 VAL) VAL)
(: 'min_big_loop)
  (mov (@ -4 EXP TEMP 2) UNEV)
  (cmp (@ -4 VAL TEMP 2) UNEV)
  (jb 'min_big_less)
  (ja 'min_big_next)
  (loop 'min_big_loop)
(: 'min_big_next)
  (clear UNEV EXP)
  (pop VAL)
  (pop EXP)
  (jmp 'min_next)
(: 'min_big_less)
  (clear UNEV EXP)
  (pop EXP)
  (pop VAL)
  (jmp 'min_less_continue)
(: 'min_simple)
  (mov (@ 4 EXP) TEMP)
  (cmp (@ 4 VAL) TEMP)
  (jnb 'min_next)
(: 'min_less)
  (mov EXP VAL)
(: 'min_less_continue)
  (mov (@ VAL) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
(: 'min_next)
  (mov (@ 4 ARGL) ARGL)
  (jmpl 'min_loop)

(: 'min_negative)
  (test #x00020000 (@ VAL))
  (jz 'min_less)
  (shr 18 TEMP)
  (cmp (@ 'src1size) TEMP)
  (ja 'min_less)
  (jb 'min_next)
  (jecxz 'min_negative_simple)
  (push EXP)
  (push VAL)
  (mov (@ 4 EXP) EXP)
  (mov (@ 4 VAL) VAL)
(: 'min_negative_big_loop)
  (mov (@ -4 EXP TEMP 2) UNEV)
  (cmp (@ -4 VAL TEMP 2) UNEV)
  (ja 'min_big_less)
  (jb 'min_big_next)
  (loop 'min_negative_big_loop)
  (jmp 'min_big_next)
(: 'min_negative_simple)
  (mov (@ 4 EXP) TEMP)
  (cmp (@ 4 VAL) TEMP)
  (jna 'min_next)
  (jmp 'min_less)

(: 'min_max_end)
  (mov (@ VAL) TEMP)
  (or! TEMP (@ FREE))
  (mov (@ 4 VAL) VAL)
  (mov VAL (@ 4 FREE))
  (mov FREE VAL)
  (jmpl 'advance_free)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "max")
  (insure-more-args ARGL)
  (mov INTEGER (@ FREE))
  (get-number-exactness FREE)
  (mov EXP VAL) ;max thus far
  (mov (@ 4 ARGL) ARGL)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_max_first)
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
(: 'max_loop)
  (test ARGL ARGL)
  (jz 'min_max_end)
  (get-number-exactness FREE)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_max)
  (test #x00020000 (@ EXP))
  (jnz 'max_negative)
  (test #x00020000 (@ VAL))
  (jnz 'max_greater)
  (shr 18 TEMP)
  (cmp (@ 'src1size) TEMP)
  (ja 'max_greater)
  (jb 'max_next)
  (jecxz 'max_simple)
  (push EXP)
  (push VAL)
  (mov (@ 4 EXP) EXP)
  (mov (@ 4 VAL) VAL)
(: 'max_big_loop)
  (mov (@ -4 EXP TEMP 2) UNEV)
  (cmp (@ -4 VAL TEMP 2) UNEV)
  (ja 'max_big_greater)
  (jb 'max_big_next)
  (loop 'max_big_loop)
(: 'max_big_next)
  (clear UNEV EXP)
  (pop VAL)
  (pop EXP)
  (jmp 'max_next)
(: 'max_big_greater)
  (clear UNEV EXP)
  (pop EXP)
  (pop VAL)
  (jmp 'max_greater_continue)
(: 'max_simple)
  (mov (@ 4 EXP) TEMP)
  (cmp (@ 4 VAL) TEMP)
  (jna 'max_next)
(: 'max_greater)
  (mov EXP VAL)
(: 'max_greater_continue)
  (mov (@ VAL) TEMP)
  (shr 18 TEMP)
  (mov TEMP (@ 'src1size))
(: 'max_next)
  (mov (@ 4 ARGL) ARGL)
  (jmpl 'max_loop)

(: 'max_negative)
  (test #x00020000 (@ VAL))
  (jz 'max_next)
  (shr 18 TEMP)
  (cmp (@ 'src1size) TEMP)
  (jb 'max_greater)
  (ja 'max_next)
  (jecxz 'max_negative_simple)
  (push EXP)
  (push VAL)
  (mov (@ 4 EXP) EXP)
  (mov (@ 4 VAL) VAL)
(: 'max_negative_big_loop)
  (mov (@ -4 EXP TEMP 2) UNEV)
  (cmp (@ -4 VAL TEMP 2) UNEV)
  (jb 'max_big_greater)
  (ja 'max_big_next)
  (loop 'max_negative_big_loop)
  (jmp 'max_big_next)
(: 'max_negative_simple)
  (mov (@ 4 EXP) TEMP)
  (cmp (@ 4 VAL) TEMP)
  (jnb 'max_next)
  (jmp 'max_greater)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "exact->inexact")
  (call 'get_last_number)
  (test #x10000 TEMP)
  (jz 'prim_return_new_exactness)
  (ret)

(new-primitive "inexact->exact")
  (call 'get_last_number)
  (test #x10000 TEMP)
  (jnz 'prim_return_new_exactness)
  (ret)

(: 'prim_return_new_exactness)
  (xor #x10000 TEMP)
  (mov TEMP (@ FREE))
  (mov (@ 4 VAL) TEMP)
  (mov TEMP (@ 4 FREE))
  (mov FREE VAL)
  (jmpl 'advance_free)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "round")
  (call 'get_last_number)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_round)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "ceiling")
  (call 'get_last_number)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_ceiling)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "floor")
  (call 'get_last_number)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_floor)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "truncate")
  (call 'get_last_number)
  (opd-size)(cmp INTEGER TEMP)
  (jnel 'rational_truncate)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (make-integer-comparator name conditional-jump tower-first tower-next)
  (define compare-integers-loop (symbol-seq))
  (new-primitive name)
  (test ARGL ARGL)
  (jzl 'return_true)
  (mov (@ ARGL) EXP)
  (test EXP EXP)
  (jzl 'error_expected_number)
  (mov (@ EXP) TEMP)
  (opd-size)(cmp INTEGER TEMP)
  (jnel tower-first)

  (: compare-integers-loop)
  (mov (@ 4 ARGL) ARGL)
  (test ARGL ARGL)
  (jzl 'return_true)
  (mov EXP VAL)
  (mov (@ ARGL) EXP)
  (test EXP EXP)
  (jzl 'error_expected_number)
  (mov (@ EXP) TEMP)
  (opd-size)(cmp INTEGER TEMP)
  (jnel tower-next)
  (conditional-jump compare-integers-loop))

(define (jump-if-positive x dest)
  (test #x00020000 x)
  (jzl dest))
(define (jump-if-negative x dest)
  (test #x00020000 x)
  (jnzl dest))
(make-integer-comparator "="
  (lambda (compare-integers-loop)
    (xor (@ VAL) TEMP)
    (test #xfffe0000 TEMP)
    (jnz 'compare_=_false) ;signs or sizes differ
    (mov (@ VAL) TEMP)
    (shr 18 TEMP)
    (jecxz 'compare_=_simple)
    (mov (@ 4 VAL) VAL)
   (: 'compare_=_loop)
    (mov (@ 4 EXP) UNEV)
    (mov (@ -4 UNEV TEMP 2) UNEV)
    (cmp UNEV (@ -4 VAL TEMP 2))
    (mov 0 UNEV)
    (jne 'compare_=_false)
    (loop 'compare_=_loop)
    (jmp compare-integers-loop)
   (: 'compare_=_simple)
    (mov (@ 4 VAL) VAL)
    (cmp (@ 4 EXP) VAL)
    (je compare-integers-loop)
   (: 'compare_=_false)
    (return-false))
  'rational_=_first 'return_false)
(make-integer-comparator ">"
  (lambda (compare-integers-loop)
    (jump-if-negative (@ VAL) 'compare_>_negative)
    (jump-if-negative TEMP compare-integers-loop)
    (shr 18 TEMP)
    (mov TEMP (@ 'src2size))
    (mov (@ VAL) TEMP)
    (shr 18 TEMP)
    (cmp (@ 'src2size) TEMP)
    (jbl 'compare_>_false)
    (ja compare-integers-loop)
    (jecxz 'compare_>_simple)
    (mov (@ 4 VAL) VAL)
   (: 'compare_>_loop)
    (mov (@ 4 EXP) UNEV)
    (mov (@ -4 UNEV TEMP 2) UNEV)
    (cmp UNEV (@ -4 VAL TEMP 2))
    (mov 0 UNEV)
    (jal compare-integers-loop)
    (jbl 'compare_>_false)
    (loop 'compare_>_loop)
    (jmp 'compare_>_false)
   (: 'compare_>_simple)
    (mov (@ 4 VAL) VAL)
    (cmp (@ 4 EXP) VAL)
    (jal compare-integers-loop)
    (return-false)
   (: 'compare_>_negative)
    (jump-if-positive TEMP 'compare_>_false)
    (shr 18 TEMP)
    (mov TEMP (@ 'src2size))
    (mov (@ VAL) TEMP)
    (shr 18 TEMP)
    (cmp (@ 'src2size) TEMP)
    (ja 'compare_>_false)
    (jbl compare-integers-loop)
    (jecxz 'compare_>_negative_simple)
    (mov (@ 4 VAL) VAL)
   (: 'compare_>_negative_loop)
    (mov (@ 4 EXP) UNEV)
    (mov (@ -4 UNEV TEMP 2) UNEV)
    (cmp UNEV (@ -4 VAL TEMP 2))
    (mov 0 UNEV)
    (jbl compare-integers-loop)
    (jal 'compare_>_false)
    (loop 'compare_>_negative_loop)
    (jmp 'compare_>_false)
   (: 'compare_>_negative_simple)
    (mov (@ 4 VAL) VAL)
    (cmp (@ 4 EXP) VAL)
    (jbl compare-integers-loop)
   (: 'compare_>_false)
    (return-false))
  'rational_>_first 'rational_>)
(make-integer-comparator ">="
  (lambda (compare-integers-loop)
    (jump-if-negative (@ VAL) 'compare_>=_negative)
    (jump-if-negative TEMP compare-integers-loop)
    (shr 18 TEMP)
    (mov TEMP (@ 'src2size))
    (mov (@ VAL) TEMP)
    (shr 18 TEMP)
    (cmp (@ 'src2size) TEMP)
    (jbl 'compare_>=_false)
    (jal compare-integers-loop)
    (jecxz 'compare_>=_simple)
    (mov (@ 4 VAL) VAL)
   (: 'compare_>=_loop)
    (mov (@ 4 EXP) UNEV)
    (mov (@ -4 UNEV TEMP 2) UNEV)
    (cmp UNEV (@ -4 VAL TEMP 2))
    (mov 0 UNEV)
    (jb 'compare_>=_false)
    (jal compare-integers-loop)
    (loop 'compare_>=_loop)
    (jmpl compare-integers-loop)
   (: 'compare_>=_simple)
    (mov (@ 4 VAL) VAL)
    (cmp (@ 4 EXP) VAL)
    (jael compare-integers-loop)
    (return-false)
   (: 'compare_>=_negative)
    (jump-if-positive TEMP 'compare_>=_false)
    (shr 18 TEMP)
    (mov TEMP (@ 'src2size))
    (mov (@ VAL) TEMP)
    (shr 18 TEMP)
    (cmp (@ 'src2size) TEMP)
    (ja 'compare_>=_false)
    (jbl compare-integers-loop)
    (jecxz 'compare_>=_negative_simple)
    (mov (@ 4 VAL) VAL)
   (: 'compare_>=_negative_loop)
    (mov (@ 4 EXP) UNEV)
    (mov (@ -4 UNEV TEMP 2) UNEV)
    (cmp UNEV (@ -4 VAL TEMP 2))
    (mov 0 UNEV)
    (ja 'compare_>=_false)
    (jbl compare-integers-loop)
    (loop 'compare_>=_negative_loop)
    (jmpl compare-integers-loop)
   (: 'compare_>=_negative_simple)
    (mov (@ 4 VAL) VAL)
    (cmp (@ 4 EXP) VAL)
    (jbel compare-integers-loop)
   (: 'compare_>=_false)
    (return-false))
  'rational_>=_first 'rational_>=)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rational Math Primitives ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "numerator")
  (call 'get_last_number)
  (opd-size)(cmp INTEGER TEMP)
  (je 'numerator_end)
(: 'numerator_rational)
  (opd-size)(cmp RATIONAL TEMP)
  (jnel 'error_expected_rational)
  (mov (@ 4 VAL) VAL) ;(numerator . denominator)
  (mov (@ VAL) VAL) ;numerator
(: 'numerator_end)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "denominator")
  (call 'get_last_number)
  (opd-size)(cmp INTEGER TEMP)
  (jne 'denominator_rational)
  (mov (object INTEGER 1) VAL)
  (jmpl 'advance_free)

(: 'denominator_rational)
  (opd-size)(cmp RATIONAL TEMP)
  (jnel 'error_expected_rational)
  (mov (@ 4 VAL) VAL)
  (mov (@ 4 VAL) VAL)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Upgrades from Integer procedures ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;tower_procedures vector index:
(define tower+ 0) ;(+ a b)
(define tower- 1) ;(- a)
(define tower* 2) ;(* a b)
(define tower= 3) ;(= a b)
(define tower> 4) ;(> a b)
(define tower>= 5) ;(>= a b)
(define tower-round 6) ;(round a)
(define tower-truncate 7) ;(truncate a)
(define tower-floor 8) ;(floor a)

(define (tower-jump index)
  (mov (* (+ index 1) 4) TEMP)
  (add (@ 'tower_procedures) TEMP) 
  (mov (@ TEMP) VAL)
  (jmpl 'apply_direct))

(define (tower-call index)
  (mov (* (+ index 1) 4) TEMP)
  (add (@ 'tower_procedures) TEMP) 
  (mov (@ TEMP) VAL)
  (call 'apply_direct))

(new-primitive "tower-procedures")
  (mov (@ 'tower_procedures) VAL)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'rational_add_loop)
  (mov (@ ARGL) EXP)
;;Accumulated value in VAL, First number of ARGL in EXP
(: 'rational_add)
  (mov (object VAL 0) VAL)
  (call 'advance_free)
  (mov (object EXP VAL) UNEV)
  (call 'advance_free)
  (save ARGL)
  (tower-call tower+)
  (restore ARGL)
  (mov (@ 4 ARGL) ARGL)
  (test ARGL ARGL)
  (jnz 'rational_add_loop)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'rational_subtract_first)
  (mov ARGL UNEV)
  (mov EXP VAL)
  (mov (@ 4 ARGL) ARGL)
  (test ARGL ARGL)
  (jnz 'rational_subtract)
(: 'rational_additive_inverse)
  (tower-jump tower-)

(: 'rational_subtract)
  (save VAL)
  (mov (object INTEGER 0) VAL)
  (call 'advance_free)
  (call 'rational_add_loop)
  (mov (object VAL 0) UNEV)
  (call 'advance_free)
  (call 'rational_additive_inverse)
  (mov (object VAL 0) UNEV)
  (call 'advance_free)
  (restore VAL)
  (mov (object VAL UNEV) UNEV)
  (call 'advance_free)
  (tower-jump tower+)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'rational_multiply_loop)
  (mov (@ ARGL) EXP)
;;Accumulated value in VAL, First number of ARGL in EXP
(: 'rational_multiply)
  (mov (object VAL 0) VAL)
  (call 'advance_free)
  (mov (object EXP VAL) UNEV)
  (call 'advance_free)
  (save ARGL)
  (tower-call tower*)
  (restore ARGL)
  (mov (@ 4 ARGL) ARGL)
  (test ARGL ARGL)
  (jnz 'rational_multiply_loop)
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-tower-comparator index entry entry-first)
  (define comparator-loop (symbol-seq))
  (define comparator-end (symbol-seq))
  (: entry)
  (mov VAL EXP)
  (: comparator-loop)
  (mov (@ ARGL) VAL)
  (mov (object VAL 0) UNEV)
  (call 'advance_free)
  (mov (object EXP UNEV) UNEV)
  (call 'advance_free)
  (save ARGL)
  (tower-call index)
  (restore ARGL)
  (cmp 'false VAL)
  (je comparator-end)
  (mov (@ ARGL) EXP)
  (: entry-first)
  (mov (@ 4 ARGL) ARGL)
  (test ARGL ARGL)
  (jnz comparator-loop)
  (return-true)
  (: comparator-end)
  (ret))

(make-tower-comparator tower= 'rational_= 'rational_=_first)
(make-tower-comparator tower> 'rational_> 'rational_>_first)
(make-tower-comparator tower>= 'rational_>= 'rational_>=_first)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Number in VAL, header in TEMP
(: 'rational_negative)
  (opd-size)(cmp RATIONAL TEMP)
  (jnel 'real_negative)
  (mov (@ 4 VAL) VAL) ;(numerator . denominator)
  (mov (@ VAL) VAL) ;numerator
  (mov (@ VAL) TEMP)
  (jmpl 'integer_negative)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Number in EXP, header in TEMP
(: 'rational_abs)
  (save EXP)
  (mov EXP VAL)
  (mov (@ VAL) TEMP)
  (call 'rational_negative)
  (restore EXP)
  (cmp 'true VAL)
  (jel 'rational_abs_negate)
  (mov EXP VAL)
  (ret)

(: 'rational_abs_negate)
  (mov (object EXP 0) UNEV)
  (call 'advance_free)
  (jmpl 'rational_additive_inverse)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Number in VAL, header in TEMP
(: 'rational_positive)
  (opd-size)(cmp RATIONAL TEMP)
  (jnel 'real_positive)
  (mov (@ 4 VAL) VAL) ;(numerator . denominator)
  (mov (@ VAL) VAL) ;numerator
  (mov (@ VAL) TEMP)
  (jmpl 'integer_positive)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'rational_round)
  (mov ARGL UNEV)
  (tower-jump tower-round)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'rational_truncate)
  (mov ARGL UNEV)
  (tower-jump tower-truncate)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'rational_floor)
  (mov ARGL UNEV)
  (tower-jump tower-floor)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'rational_ceiling)
  (mov ARGL UNEV)
  (tower-call tower-floor)
  (inc (@ 4 VAL))
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(: 'rational_min_smaller)
  (restore #f)
  (mov (@ ARGL) VAL) ;New minimum
  (mov (@ 4 ARGL) ARGL)
(: 'rational_min_first) ;VAL is min thus far
  (test ARGL ARGL)
  (jzl 'rational_min_end)
  (get-number-exactness FREE)
(: 'rational_min)
  (push (@ FREE)) ;remember exactness thus far
  (mov (object EXP 0) UNEV)
  (call 'advance_free)
  (mov (object VAL UNEV) UNEV)
  (call 'advance_free)
  (save VAL ARGL)
  (tower-call tower>) ;(> VAL EXP)
  (pop (@ FREE))
  (restore ARGL)
  (cmp 'true VAL)
  (jel 'rational_min_smaller)
  (restore VAL)
  (mov (@ 4 ARGL) ARGL)
  (jmpl 'rational_min_first)

(: 'rational_min_end)
(: 'rational_max_end)
  (and! #x10000 (@ FREE)) ;keep only the exactness
  (mov (@ VAL) TEMP)
  (or! TEMP (@ FREE)) ;and apply to header
  (mov (@ 4 VAL) TEMP)
  (mov TEMP (@ 4 FREE))
  (mov FREE VAL)
  (jmpl 'advance_free)

(: 'rational_max_larger)
  (restore #f)
  (mov (@ ARGL) VAL) ;New maximum
  (mov (@ 4 ARGL) ARGL)
(: 'rational_max_first) ;VAL is max thus far
  (test ARGL ARGL)
  (jz 'rational_max_end)
  (get-number-exactness FREE)
(: 'rational_max)
  (push (@ FREE)) ;remember exactness thus far
  (mov (object VAL 0) UNEV)
  (call 'advance_free)
  (mov (object EXP UNEV) UNEV)
  (call 'advance_free)
  (save VAL ARGL)
  (tower-call tower>) ;(> EXP VAL)
  (pop (@ FREE))
  (restore ARGL)
  (cmp 'true VAL)
  (jel 'rational_max_larger)
  (restore VAL)
  (mov (@ 4 ARGL) ARGL)
  (jmpl 'rational_max_first)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Real Math Primitives ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-additional-primitive "make-real")
  (insure-one-last-arg ARGL)
  (mov (@ ARGL) EXP)
  (test EXP EXP)
  (jzl 'error_expected_procedure)
  (mov (@ 4 EXP) EXP)
  (mov (object REAL EXP) VAL)
  (jmpl 'advance_free)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Number in VAL, header in TEMP
(: 'real_positive)
  (mov (object INTEGER 0) VAL)
  (call 'advance_free)
  (mov (object VAL 0) VAL)
  (call 'advance_free)
  (mov (@ ARGL) ARGL)
  (mov (object ARGL VAL) UNEV)
  (call 'advance_free)
  (tower-jump tower>)
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Number in VAL, header in TEMP
(: 'real_negative)
  (mov (object INTEGER 0) VAL)
  (call 'advance_free)
  (mov (object VAL ARGL) UNEV)
  (call 'advance_free)
  (tower-jump tower>)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Complex Math Primitives ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "make-rectangular")
  (mov COMPLEX (@ FREE))
  (mov FREE VAL)
  (lea (@ 8 FREE) TEMP)
  (mov TEMP (@ 4 FREE))
  (insure-more-args ARGL)
  (get-number-exactness FREE)
  (mov EXP (@ 8 FREE))
  (mov (@ 4 ARGL) ARGL)
  (insure-one-last-arg ARGL)
  (get-number-exactness FREE)
  (mov EXP (@ 12 FREE))
  (add 8 FREE)
  (jmpl 'advance_free)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "real-part")
  (call 'get_last_number)
  (opd-size)(cmp COMPLEX TEMP)
  (ife
    (begin
      (mov (@ 4 VAL) VAL)
      (mov (@ VAL) VAL)))
  (ret)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(new-primitive "imag-part")
  (call 'get_last_number)
  (opd-size)(cmp COMPLEX TEMP)
  (jnel 'return_zero)
  (mov (@ 4 VAL) VAL)
  (mov (@ 4 VAL) VAL)
  (ret)
