program FloatVal {
  This does, in detail, what Pascal/Delphi does with an assignment statement
  between different float types; but it could be translated by those
  who want to read Pascal/Delphi/IEEE data in other languages.
  Consider the rounding or truncation of each method.
  See http://www.merlyn.demon.co.uk/pas-type.htm#Conv } ;

type Tanswer = extended { single real double extended } ;

function TwoTo(const P : integer) : extended ;
var S : extended ; J : integer ;
begin S := 1 ;
  for J := 1 to Abs(P) do S := 2.0*S ; { but see ... }
  if P<0 then S := 1.0/S ;
  TwoTo := S end {TwoTo} ;

{ Functions XxxToAns convert, using arithmetic with any convenient type,
  to a known type }

function FourToAns(const Four : single) : Tanswer ;
var S : extended ; A : longint absolute Four ;
begin
  if (A and $7FFFFFFF)=0 then begin FourToAns := 0.0 ; EXIT end ;
  S := 1.0 + (A and $007FFFFF)/$00800000 ;
  if A<0 then S := -S ;
  FourToAns := S * TwoTo( ( (A shr 23) and $FF ) -127) end {FourToAns} ;

function SixToAns(const Six : real{48}) : Tanswer ;
const Q6 : extended = 1.0/256.0 ;
type A6 = array [1..6] of byte ;
var S : extended ; A : A6 absolute Six ;
begin
  if A[1]=0 then begin SixToAns := 0.0 ; EXIT end ;
  S := 1.0 + 2.0 * ((((A[2]*Q6+A[3])*Q6+A[4])*Q6+A[5])*Q6+(A[6] and $7F))*Q6 ;
  if A[6]>127 then S := -S ;
  SixToAns := S * TwoTo(integer(A[1])-129) end {SixToAns} ;

function EightToAns(const Eight : double) : Tanswer ;
const Q8 : extended = 1.0/65536.0 ;
type A8 = array [1..4] of word ;
var S : extended ; A : A8 absolute Eight ;
begin
  if ((A[4] and $7FFF) or A[3] or A[2] or A[1])=0 then
    begin EightToAns := 0.0 ; EXIT end ;
  S := 1.0 + 0.0625 * (((A[1]*Q8+A[2])*Q8+A[3])*Q8+(A[4] and $000F)) ;
  if A[4]>32767 then S := -S ;
  EightToAns := S * TwoTo(integer( (A[4] shr 4) and $7FF)-1023) ;
  end {EightToAns} ;

function TenToAns(const Ten : extended) : Tanswer ;
const QX : extended = 1.0/65536.0 ;
type AX = array [1..5] of word ;
var S : extended ; A : AX absolute Ten ;
begin { Ignores NaN & Inf }
  S := 2.0 * (((A[1]*QX+A[2])*QX+A[3])*QX+A[4])*QX ;
  if A[5]>32767 then S := -S ;
  TenToAns := S * TwoTo(integer(A[5] and $7FFF)-16383) end {TenToAns} ;


const Tests = 8 ; W1 = 24 ;
XX : array [boolean] of char = 'NY' ;

procedure Test4 ;
Var J : integer ; ZZ, QM, QP : TAnswer ;
const W2 = 7 ;
begin Writeln(^M^J'Test4 :') ;
  for J := 1 to Tests do begin ZZ := Random*100.0 ;
    QP := FourToAns(ZZ) ; QM := FourToAns(-ZZ) ;
{ writeln(zz, '':3, QP-ZZ, '':3, (QP-ZZ)*16*1024*1024) ; }
    Writeln(ZZ:W1:W2, QP:W1:W2, QM:W1:W2, '':2, XX[QP=ZZ], XX[QM=-ZZ]) ;
    end ;
  Writeln(0.0:W1:W2, FourToAns(0.0):W1) ;   { readln ; HALT ; }
  end {Test4} ;

procedure Test6 ;
Var J : integer ; ZZ, QM, QP : Tanswer ;
const W2 = 11 ;
begin Writeln(^M^J'Test6 :') ;
  for J := 1 to Tests do begin ZZ := Random*100.0 ;
    QP := SixToAns(ZZ) ; QM := SixToAns(-ZZ) ;
    Writeln(ZZ:W1:W2, QP:W1:W2, QM:W1:W2, '':2, XX[QP=ZZ], XX[QM=-ZZ]) ;
    end ;
  Writeln(0.0:W1:W2, SixToAns(0.0):W1) ;
  end {Test6} ;

procedure Test8 ;
Var J : integer ; ZZ, QM, QP : Tanswer ;
const W2 = 15 ;
begin Writeln(^M^J'Test8 :') ;
  for J := 1 to Tests do begin ZZ := Random*100.0 ;
    QP := EightToAns(ZZ) ; QM := EightToAns(-ZZ) ;
    Writeln(ZZ:W1:W2, QP:W1:W2, QM:W1:W2, '':2, XX[QP=ZZ], XX[QM=-ZZ]) ;
    end ;
  Writeln(0.0:W1:W2, EightToAns(0.0):W1) ;
  end {Test8} ;

procedure TestX ;
Var J : integer ; ZZ, QM, QP : Tanswer ;
const W2 = 19 ;
begin Writeln(^M^J'TestX :') ;
  for J := 1 to Tests do begin ZZ := Random*100.0 ;
    QP := TenToAns(ZZ) ; QM := TenToAns(-ZZ) ;
    Writeln(ZZ:W1:W2, QP:W1:W2, QM:W1:W2, '':2, XX[QP=ZZ], XX[QM=-ZZ]) ;
    end ;
  Writeln(0.0:W1:W2, TenToAns(0.0):W1) ;
  end {TestX} ;

type T6 = array [1..6] of byte ;

{ Procedures XxxToSix convert, to Borland six-byte real, by bit
  shifting; they can be translated for generating 6-byte reals
  in languages that do not support them }

procedure TenToSix(const Q : extended ; var R : T6) ;
type TX = array [1..10] of byte ;
type T5 = array [1..5] of word ;
var X : TX ; E : word ;
const K = 16383-129 ;
begin extended(X) := Q ;
  FillChar(R, SizeOf(R), 0) ;
  if Q=0 then EXIT ;
  if X[8]<$80 then RunError(233) { Denormalised } ;
  E := T5(Q)[5] and $7FFF ;
  if E<K then EXIT { Underflow } ;
  if E>K+$FF then RunError(234) { Overflow } ;
  R[1] := E - K ;
  Move(X[4], R[2], 5) ;
  if Q<0.0 then R[6] := (R[6] or $80) else R[6] := (R[6] and $7F) ;
  end {TenToSix} ;

procedure EightToSix(const Q : double ; var R : T6) ;
type T8 = array [1..8] of byte ;
type T4 = array [1..4] of word ;
var X : T8 ; E : word ;
const K = 1023-129 ;
begin double(X) := Q ;
  FillChar(R, SizeOf(R), 0) ;
  if Q=0 then EXIT ;
  E := (T4(Q)[4] shr 4 and $7FF) ;
  if E<K then EXIT { Underflow } ;
  if E>K+$FF then RunError(234) { Overflow } ;
  R[1] := E - K ;
  for E := 6 downto 2 do
    R[E] := ((X[E+1] shl 3) and $F8) or ((X[E] shr 5) and $07) ;
  if Q<0.0 then R[6] := (R[6] or $80) else R[6] := (R[6] and not $80) ;
  end {EightToSix} ;

procedure FourtoSix(const Q : single ; var R : T6) ;
type T4 = array [1..4] of byte ;
type T2 = array [1..2] of word ;
var X : T4 ; E : word ;
const K = 127-129 ;
begin single(X) := Q ;
  FillChar(R, SizeOf(R), 0) ;
  if Q=0 then EXIT ;
  E := (T2(Q)[2] shr 7 and $FF) ;
  if E<K then EXIT { Underflow ?? } ;
  if E>K+$FF then RunError(234) { Overflow } ;
  R[1] := E - K ;
  Move(X[1], R[4], 3) ;
  if Q<0.0 then R[6] := (R[6] or $80) else R[6] := (R[6] and not $80) ;
  end {FourtoSix} ;

procedure TenSixTest;
Var J : integer ; ZZ : extended ; QM, QP : T6 ;
const W2 = 11 ;
begin Writeln(^M^J'TenSixTest :') ;
  for J := 1 to Tests do begin ZZ := Random*100.0 ;
    TenToSix(ZZ, QP) ; TenToSix(-ZZ, QM) ;
    Writeln(ZZ:W1:W2, real(QP):W1:W2, real(QM):W1:W2 {, '':2, XX[QP=ZZ], XX[QM=-ZZ]}) ;
    end ;
  TenToSix(0.0, QP) ; Writeln(0.0:W1:W2, real(QP):W1) ;
  end {TenSixTest} ;

procedure EightSixTest;
Var J : integer ; ZZ : double ; QM, QP : T6 ;
const W2 = 11 ;
begin Writeln(^M^J'EightSixTest :') ;
  for J := 1 to Tests do begin ZZ := Random*100.0 ;
    EightToSix(ZZ, QP) ; EightToSix(-ZZ, QM) ;
    Writeln(ZZ:W1:W2, real(QP):W1:W2, real(QM):W1:W2 {, '':2, XX[QP=ZZ], XX[QM=-ZZ]}) ;
    end ;
  EightToSix(0.0, QP) ; Writeln(0.0:W1:W2, real(QP):W1) ;
  end {EightSixTest} ;

procedure FourSixTest;
Var J : integer ; ZZ : single ; QM, QP : T6 ;
const W2 = 11 ;
begin Writeln(^M^J'FourSixTest :') ;
  for J := 1 to Tests do begin ZZ := Random*100.0 ;
    FourtoSix(ZZ, QP) ; FourtoSix(-ZZ, QM) ;
    Writeln(ZZ:W1:W2, real(QP):W1:W2, real(QM):W1:W2 {, '':2, XX[QP=ZZ], XX[QM=-ZZ]}) ;
    end ;
  FourtoSix(0.0, QP) ; Writeln(0.0:W1:W2, real(QP):W1) ;
  end {FourSixTest} ;



BEGIN ;
Writeln('FLOATVAL.PAS   www.merlyn.demon.co.uk  >= 2002-05-13') ;
Writeln('  Slightly tested, BP7 & D3   NaN Inf denorm etc may be ignored') ;
Writeln('  Compiled with ', SizeOf(Tanswer), '-byte Tanswer.') ;
Randomize ;
Test4 ; Test6 ; Test8 ; TestX ; TenSixTest ; EightSixTest ; FourSixTest ;
Readln ;
END.