;;; -*- Mode:LISP; Package:NEW-MATH; Readtable:CL; Base:10 -*-


;********************************************************************************
; Convert fixnum to something
;********************************************************************************


(defafun convert-fixnum-to-bignum (n) ;;||| 9/29/88 --wkf
  (alu sex-r a0 ignore a0 bw-24)        ;;sign-extend right 24bw to 32bw.
  (tail-open-call (array:make-bignum-32 1) (o0 a0))
 )


(defun convert-fixnum-to-rational (n)
  (hw:dpb vinc:$$dtp-rational vinc::%%data-type (cons:cons n 1)))


;;; Convert fixnum to short, single, and double are in the FLOAT.LISP file.


(defun convert-fixnum-to-complex (n)
  (hw:dpb vinc:$$dtp-complex vinc::%%data-type (cons:cons n 0)))


;********************************************************************************
; Convert bignum to something
;********************************************************************************

(defun convert-bignum-to-rational (n)
  (hw:dpb vinc:$$dtp-rational vinc::%%data-type (cons:cons n 1)))


(defafun get-normalized-bignum-info (n)
; a0 - bignum ptr
;
; a1 - bignum size in words
; a2 - status
; a3 - index
; a4 - low
; a5 - 32
;
; a11 - middle
; a12 - high
; a13 - exponent
; a14 - sign bit
  (move vma-start-read a0 boxed-vma boxed-md) ;get length
  (movei a2 '#x10000)
  (movei a5 '32)
  (movei a11 '1)
  (move a1 md)
  (alu l+r vma-start-read-no-transport a1 a0 bw-24 unboxed-vma unboxed-md) ;get sign
  (move a11 gr:*all-zero*)
  (move a4 gr:*all-zero*)
  (movei a13 '32)
  (alu r-1 a1 ignore a1 bw-24)
  (move a12 md br-zero)
  (branch have-3-words (alu sign a13 gr:*zero* gr:*zero* bw-24))
  (alu l+r vma-start-read-no-transport a1 a0 bw-24 unboxed-vma unboxed-md)
  (alu r-1 a1 ignore a1 bw-24)
  (alu l+r a13 a13 a5 bw-24 br-zero)
  (branch have-3-words (alu setr a11 ignore md))
  (alu l+r vma-start-read-no-transport a1 a0 bw-24 unboxed-vma unboxed-md)
  (alu r-1 a1 ignore a1 bw-24)
  (alu l+r a13 a13 a5 bw-24 br-zero)
  (move a4 md)
have-3-words
  (move nop a12)
  (alu-field field-extract-r r15 ignore a1 (byte 19. 5.) br-not-negative unboxed)
  (branch normalize (alu l+r a13 a13 r15 unboxed br-zero))
  (branch negate-internal (alu load-status-r nop ignore a2))
negative
  (alu l+r vma-start-read-no-transport a11 a0 bw-24 unboxed-vma unboxed-md)
  (alu l-r nop a11 a1 bw-24)
  (alu load-status-r nop ignore a2 br-less-than)
  (branch negate-internal (alu l-r-c nop gr:*all-zero* md))
  (unconditional-branch negative (alu r+1 a11 ignore a11 bw-24))
negate-internal
  (alu l-r-c a4 gr:*zero* a4)
  (alu l-r-c a11 gr:*zero* a11)
  (alu l-r-c a12 gr:*zero* a12)
normalize
  (alu r-1 a13 ignore a13 bw-24)
  (alu shift-up-0f-r a12 ignore a12)
  (alu shift-up-lf-r a11 ignore a11)
  (alu shift-up-lf-r a4 ignore a4)
  (alu prioritize-r r15 ignore a4)
  (alu l-r a2 a2 r15 bw-24)
  (alu field-extract-lr a4 a4 a11 pw-rr)
  (alu field-extract-lr a11 a11 a12 pw-rr)
  (movei a15 '7)
  (returni nil boxed-right)
 )


(defafun convert-bignum-to-short (n)
  (open-call (get-normalized-bignum-info 1) a1 (o0 a0))
  (movei a2 #x4000 unboxed)				;round off constant
  (movei a3 '128)
  (alu l-r nop a13 a3 bw-24)
  (alu l+r r12 a2 r12 br-less-or-equal)
  (branch no-overflow ())
overflow
  (open-call (float-illop 0) a15 ())
no-overflow
  (movei a2 vinc:$$dtp-short-float unboxed)
  (alu-field field-pass a2 a2 gr:*all-zero* (byte 6. 26.) unboxed) 	;data type
  (alu-field field-pass a2 r14 a2 (byte 1. 25.) unboxed)		;sign bit
  (movei a15 '127)							;exponent
  (alu l-r a15 r13 a15 bw-24)
  (alu-field field-pass a2 r13 a2 (byte 8. 17.) unboxed)
  (alu-field field-pass return r12 a2 (byte 17. -5.) boxed ch-return next-pc-return)
 )


(defafun convert-bignum-to-single (n)
  (open-call (get-normalized-bignum-info 1) a1 (o0 a0))
  (movei a2 #x100 unboxed)						;round off constant
  (movei a3 '128)
  (alu l-r nop a13 a3 bw-24)
  (alu l+r r12 a2 r12 br-less-or-equal)
  (branch no-overflow ())
overflow
  (open-call (float-illop 0) a15 ())
no-overflow
  (alu-field field-pass a2 r14 gr:*all-zero* (byte 1. 31.) unboxed)	;sign bit
  (movei a15 '127)							;exponent
  (alu l-r a15 r13 a15 bw-24)
  (alu-field field-pass a2 r13 a2 (byte 8. 23.) unboxed)
  (alu-field field-pass a2 r12 a2 (byte 23. -9.) unboxed)
  (tail-open-call (array:make-single-float 1) (o0 a2))
 )


(defafun convert-bignum-to-double (n)
  (open-call (get-normalized-bignum-info 1) a1 (o0 a0))
  (movei a2 #x4000 unboxed)						;round off constant
  (movei a3 '2048)
  (alu l-r nop a13 a3 bw-24)
  (alu l+r r11 a2 r11 br-less-or-equal)
  (branch no-overflow (alu l+r+c r12 gr:*all-zero* r12))
overflow
  (open-call (float-illop 0) a15 ())
no-overflow
  (alu-field field-pass a2 r14 a2 (byte 1. 25.) unboxed)		;sign bit
  (movei a15 '1023)							;exponent
  (alu l-r a15 r13 a15 bw-24)
  (alu-field field-pass a2 r13 a2 (byte 11. 20.) unboxed)
  (alu-field field-pass a2 r12 a2 (byte 20. -12.) unboxed)		;mantissa
  (alu-field field-extract-lr o0 r12 r11 (byte 32. -12.) unboxed ch-tail-open)
  (tail-call (array:make-double-float 2) (o1 a2))
 )


(defun convert-bignum-to-complex (n)
  (hw:dpb vinc:$$dtp-complex vinc::%%data-type (cons:cons n 0)))

;********************************************************************************
; Convert rational to something
;********************************************************************************
(defun convert-rational-to-short (x)
  (let ((n (generic-math-type-coercer (numerator x)   (convert-fixnum-to-short 0))) ;;;@@@ Inefficient --wkf
	(d (generic-math-type-coercer (denominator x) (convert-fixnum-to-short 0))))
    (divide-short n d)))

(defun convert-rational-to-single (x)
  (let ((n (generic-math-type-coercer (numerator x)   (convert-fixnum-to-single 0)))
	(d (generic-math-type-coercer (denominator x) (convert-fixnum-to-single 0))))
    (divide-single n d)))

(defun convert-rational-to-double (x)
  (let ((n (generic-math-type-coercer (numerator x)   (convert-fixnum-to-double 0)))
	(d (generic-math-type-coercer (denominator x) (convert-fixnum-to-double 0))))
    (divide-double n d)))

(defun convert-rational-to-complex (x)
  (hw:dpb $$dtp-complex vinc::%%data-type (cons:cons x 0)))

;********************************************************************************
; Convert short to something
;********************************************************************************

;;; Convert short to single and double are in the file FLOAT.LISP

(defun convert-short-to-complex (n)
  (hw:dpb vinc:$$dtp-complex vinc::%%data-type (cons:cons n 0)))

;********************************************************************************
; Convert single to something
;********************************************************************************

;;; convert-single-to-double is in the file FLOAT.LISP

(defun convert-single-to-complex (n)
  (hw:dpb vinc:$$dtp-complex vinc::%%data-type (cons:cons n 0)))

;********************************************************************************
; Convert double to something
;********************************************************************************

(defun convert-double-to-complex (n)
  (hw:dpb vinc:$$dtp-complex vinc::%%data-type (cons:cons n 0)))

;********************************************************************************
; Floating point error message
;********************************************************************************

(defun float-illop ()
  (trap:illop "Error in floating point conversions"))