home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Pascal / BPASCAL.700 / LIB / TESTPRGS.ZIP / ROUNDTST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-03-09  |  3.3 KB  |  127 lines
  1. PROGRAM RoundTst;  { Copyright (c) 1992,1993 Norbert Juffa }
  2.  
  3. { RoundTst test correct implementation of TRUNC and ROUND for REAL arithmetic }
  4.  
  5. {$N+}
  6.  
  7. USES Fun1_TP6;
  8.  
  9. VAR X,Y,Z: REAL;
  10.     I,II,LL,L,K:  LONGINT;
  11.     XA:ARRAY [1..6] OF BYTE ABSOLUTE X;
  12.  
  13. BEGIN
  14.    Y := 4.5;
  15.    Z := 5.5;
  16.    WriteLn ('Testing implementation of Round/Trunc for correct range and IEEE-rounding');
  17.    WriteLn;
  18.    WriteLn;
  19.    Write   ('Testing range of Round towards lower limit ... ');
  20.    X := -2147483647.0;
  21.    REPEAT
  22.       I := Round_TP60 (X);
  23. {$IFDEF PRINT}
  24.       WriteLn (X+2147483648.0);
  25. {$ENDIF}
  26.       X := X - 1.0/256.0;
  27.    UNTIL X < -2147483648.5;
  28.    WriteLn ('passed');
  29.    WriteLn;
  30.    Write   ('Testing range of Round towards upper limit ... ');
  31.    X := 2147483647.0;
  32.    REPEAT
  33.       I := Round_TP60 (X);
  34. {$IFDEF PRINT}
  35.       WriteLn (x-2147483648.0);
  36. {$ENDIF}
  37.       X := X + 1.0/256.0;
  38.    UNTIL X >= 2147483647.5;
  39.    WriteLn ('passed');
  40.    WriteLn;
  41.    Write   ('Testing range of Trunc towards lower limit ... ');
  42.    X := -2147483647.0;
  43.    REPEAT
  44.       I := Trunc_TP60 (X);
  45. {$IFDEF PRINT}
  46.       WriteLn (x+2147483648.0);
  47. {$ENDIF}
  48.       X := X - 1.0/256.0;
  49.    UNTIL X <= -2147483649.0;
  50.    WriteLn ('passed');
  51.    WriteLn;
  52.    Write   ('Testing range of Trunc towards upper limit ... ');
  53.    X := 2147483647.0;
  54.    REPEAT
  55.       I := Trunc_TP60 (X);
  56. {$IFDEF PRINT}
  57.       WriteLn (x-2147483648.0);
  58. {$ENDIF}
  59.       X := X + 1.0/256.0;
  60.    UNTIL X >= 2147483648.0;
  61.    WriteLn ('passed');
  62.    WriteLn;
  63.    Write   ('Round (4.5) should be: 4, actual value is: ', Round (Y));
  64.    IF Round_Tp60 (Y) = 4 THEN
  65.       WriteLn ('   passed')
  66.    ELSE
  67.       WriteLn ('   failed');
  68.    Write   ('Round (5.5) should be: 6, actual value is: ', Round (Z));
  69.    IF Round_TP60 (Z) = 6 THEN
  70.       WriteLn ('   passed')
  71.    ELSE
  72.       WriteLn ('   failed');
  73.    WriteLn;
  74.    Y := -4.5;
  75.    Z := -5.5;
  76.    Write   ('Round (-4.5) should be:-4, actual value is:', Round (Y));
  77.    IF Round_Tp60 (Y) =-4 THEN
  78.       WriteLn ('  passed')
  79.    ELSE
  80.       WriteLn ('  failed');
  81.    Write   ('Round (-5.5) should be:-6, actual value is:', Round (Z));
  82.    IF Round_TP60 (Z) =-6 THEN
  83.       WriteLn ('  passed')
  84.    ELSE
  85.       WriteLn ('  failed');
  86.    WriteLn;
  87.    WriteLn ('Testing full range of Trunc and Round functions');
  88.    WriteLn;
  89.    WriteLn;
  90.    X := 0.0;
  91.    WHILE X < 2147483647.0 DO BEGIN
  92.       I := Trunc_TP60 (X);
  93.       II:= Trunc (X);
  94.       L := Round_TP60 (X);
  95.       LL:= Round (X);
  96.       IF I <> II THEN BEGIN
  97.          WriteLn;
  98.          WriteLn ('Error in Trunc:', X, I:10, II:10);
  99.          END;
  100.       IF L <> LL THEN BEGIN
  101.          WriteLn;
  102.          WriteLn ('Error in Round:', X, L:10, LL:10);
  103.          FOR K := 1 to 6 do begin
  104.            Write(XA[k]:4);
  105.          end; {endfor}
  106.          writeln;
  107.          END;
  108.       I := Trunc_TP60 (-X);
  109.       II:= Trunc (-X);
  110.       L := Round_TP60 (-X);
  111.       LL:= Round (-X);
  112.       IF I <> II THEN BEGIN
  113.          WriteLn;
  114.          WriteLn ('Error in Trunc:', X, I:10, II:10);
  115.          END;
  116.       IF L <> LL THEN BEGIN
  117.          WriteLn;
  118.          WriteLn ('Error in Round:', X, L:10, LL:10);
  119.          END;
  120.       IF (I AND $FF) = 0 THEN
  121.          Write (#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8#8, 'X= ', X);
  122.       X := X + 0.5;
  123.     END;
  124.     WriteLn;
  125.     WriteLn ('Test complete!');
  126. END.
  127.