'----------------------------------------------------------------------------------------
'    Name:  REAL_TO_FLOAT.TIG
'    Type:  TIGER-BASIC(tm) Source Code
'
' Purpose:  Convert a double-precisition tiger-basic real to a single-precisition float
'
'  (C) - Copyright Wilke Technology, P.O.Box 1727, D-52018 Aachen, Germany
'----------------------------------------------------------------------------------------
'	
' Thank you for using BASIC Tigers in your products. If you have questions, ideas
' or special needs, please contact your next distributor or the Tiger support team
' and visit our web site:
'
'	Wilke Technology GmbH
'	The Tiger Support Team
'	P.O.Box 1727,       D-52018 Aachen, Germany
'	Krefelder Str. 147, D-52070 Aachen, Germany
'
'	email: support@wilke-technology.com  (english)
'	email: support@wilke.de              (german)
'	Phone: +49 (241) 918 900    Mo to Fr, 7:00 to 16:00 (GMT)
'	Fax:   +49 (241) 918 9068
'
' New information, new drivers and free downloads see:
'
'	www.wilke-technology.com	     (english)
'	www.wilke.de                         (german)
'
' Sincerely,
'
'	Your Tiger Support Team
'
'
'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------
'
'	Input:	rpReal	 = double-precisition float (eight bytes) = tiger-basic: real
'	Output:	lpvFloat = single-precisition float (four bytes)  = long-variable
'		blReturn = 0 : OK
'			 = 1 : value out of range
'			 = 2 : positive infinity
'			 = 3 : negative infinity
'			 = 4 : NaN
'
'----------------------------------------------------------------------------------------
'
'	Examples for floats:
'
'	Single:  0 	10000010	01101000000000000000000
'		sign	exponent		mantissa
'
'	Double:  0 	10001110100 	0000101001000111101011101111111011000101001101001001
'		sign	exponent		mantissa
'
'----------------------------------------------------------------------------------------
SUB Real2Float( real rpReal; var long lpvFloat; var byte blReturn)
  blReturn = 0
  lpvFloat = 0								'set the return value to zero
  									'because we want to "or" the bytes
  long llSign								'the sign of the Value
  long llLow								'low 4 bytes of the real
  long llHigh								'high 4 bytes of the real
  byte blCount								'a counter variable
  byte blTemp								'a variable for temporary usage

  llLow = LREAL(rpReal)							'get the 4 low bytes
  llHigh = HREAL(rpReal)						'get the 4 high bytes

  'first check for some special cases:

  if rpReal = rfroms("<07Fh><0F0h><000h><000h><000h><000h><000h><000h>",0,-8) then
    blReturn = 2							'check if its positive infinity
    return
  endif

  if rpReal = rfroms("<0FFh><0F0h><000h><000h><000h><000h><000h><000h>",0,-8) then
    blReturn = 3							'check if its negative infinity
    return
  endif

  if (CUT_BITS(llHigh,20,12) = 0FFFh&					'check for NaN
    or CUT_BITS(llHigh,20,12) = 07FFh)&
    and (CUT_BITS(llHigh,0,20) <> 0&
    or llLow <> 0) then
    blReturn = 4
    return
  endif

  if abs(rpReal) < rfroms("<38h><0Fh><FFh><FFh><BBh><1Dh><D6h><A1h>",0,-8)&
     or abs(rpReal) > rfroms("<47h><EFh><FFh><FFh><E0h><00h><00h><00h>",0,-8) then
    blReturn = 1							'check if the range of values is valid for single
    return								'if not: warn the user
  endif


  lpvFloat = lpvFloat bitor ((CUT_BITS(llHigh,20,8) - 896) shl 23)	'get the exponent, read just the bias

  lpvFloat = lpvFloat bitor (CUT_BITS(llHigh,16,4) shl 19)		'get the upper 4 bits of the mantissa

  lpvFloat = lpvFloat bitor (CUT_BITS(llHigh,0,16) shl 3)		'get the middle 16 bits of the mantissa

  lpvFloat = lpvFloat bitor CUT_BITS((llLow shr 28), 1, 3)		'get the lower 3 bits of mantissa


  llSign = sgn(rpReal)							'get the sign of the source real

  if llSign < 0 then							'if the real is negative
    set_bit lpvFloat, 31						'=> make the result negative
  else
    res_bit lpvFloat, 31						'else: make sure the result is positive
  endif

  if bit(llLow,0) = 1 then						'now check if we have to round the value
    blTemp = 1								'blTemp is our arithmetic overflow
    for blCount = 0 to 22						'binary add a '1' to the mantissa
      if blTemp = 1 then						'if there is an overflow: go on
        if bit(lpvFloat,blCount) = 1 then				'two cases:
          blTemp = 1							'1+1 = 0, 1 overflow
          res_bit lpvFloat,blCount					'=> set the current bit to 0
        else
          blTemp = 0							'1+0 = 1, no overflow
          set_bit lpvFloat,blCount					'=> set the current bit to 1
        endif
      else								'no overflow:
	return								'everything is fine now -> return
      endif
    next
  endif

  return								'return normally

END