Gemfury

beefree / fpc-src deb

Repository URL to install this package:
Details
fpc-src / usr / share / fpcsrc / 3.2.0 / tests / test / cg / tsar1.pp
program tsar1;
{$mode objfpc}
{$o-}
var
  c0,c4,c7,c15,c31,c63,c36,c20,c68,c12 : integer;
  c3f : shortint;
  c3fff : smallint;
  c3fffffff : longint;
  c3fffffffffffffff : int64;

begin
 c0:=0;
 c4:=4;
 c7:=7;
 c15:=15;
 c31:=31;
 c63:=63;
 c36:=36;
 c20:=20;
 c68:=68;
 c12:=12;
 c3f:=$3f;
 c3fff:=$3fff;
 c3fffffff:=$3fffffff;
 c3fffffffffffffff:=$3fffffffffffffff;

 writeln('Testing constant SarInt64...');
 if SarInt64(-$3FFFFFFFFFFFFFFF,4)<>-$400000000000000 then begin
  writeln('Fail!');
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFFF,4)<>$3FFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(-$3FFFFFFFFFFFFFF0,4)<>-$3FFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFF0,4)<>$3FFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(-$3FFFFFFFFFFFFFFF,0)<>-$3FFFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFFF,0)<>$3FFFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(-$3FFFFFFFFFFFFFFF,63)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFFF,63)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(-$3FFFFFFFFFFFFFFF)<>-$2000000000000000 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFFF)<>$1FFFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 writeln;

 writeln('Testing constant SarLongint...');
 if SarLongint(-$3FFFFFFF,4)<>-$4000000 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFFF,4)<>$3FFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(-$3FFFFFF0,4)<>-$3FFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFF0,4)<>$3FFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(-$3FFFFFFF,0)<>-$3FFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFFF,0)<>$3FFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(-$3FFFFFFF,31)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFFF,31)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(-$3FFFFFFF)<>-$20000000 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFFF)<>$1FFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 writeln;

 writeln('Testing constant SarSmallint...');
 if SarSmallint(-$3FFF,4)<>-$400 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FFF,4)<>$3FF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(-$3FF0,4)<>-$3FF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FF0,4)<>$3FF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(-$3FFF,0)<>-$3FFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FFF,0)<>$3FFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(-$3FFF,15)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FFF,15)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(-$3FFF)<>-$2000 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FFF)<>$1FFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 writeln;

 writeln('Testing constant SarShortint...');
 if SarShortint(-$3F,4)<>-$4 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3F,4)<>$3 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(-$30,4)<>-$3 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($30,4)<>$3 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(-$3F,0)<>-$3F then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3F,0)<>$3F then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(-$3F,7)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3F,7)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(-$3F)<>-$20 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3F)<>$1F then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 writeln;

 writeln('Testing constant shifting overflows');
 if SarInt64($3fffffffffffffff,68)<>$3ffffffffffffff then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3fffffff,36)<>$3ffffff then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3fff,20)<>$3ff then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3f,12)<>$3 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 writeln;

 writeln('Testing SarInt64...');
 if SarInt64(-$3FFFFFFFFFFFFFFF,c4)<>-$400000000000000 then begin
  writeln('Fail!');
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFFF,c4)<>$3FFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(-$3FFFFFFFFFFFFFF0,c4)<>-$3FFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFF0,c4)<>$3FFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(-$3FFFFFFFFFFFFFFF,c0)<>-$3FFFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFFF,c0)<>$3FFFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(-$3FFFFFFFFFFFFFFF,c63)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFFF,c63)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(-c3FFFFFFFFFFFFFFF,63)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(c3FFFFFFFFFFFFFFF,63)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64(-$3FFFFFFFFFFFFFFF)<>-$2000000000000000 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarInt64($3FFFFFFFFFFFFFFF)<>$1FFFFFFFFFFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 writeln;

 writeln('Testing SarLongint...');
 if SarLongint(-$3FFFFFFF,c4)<>-$4000000 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFFF,c4)<>$3FFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(-$3FFFFFF0,c4)<>-$3FFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFF0,c4)<>$3FFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(-$3FFFFFFF,c0)<>-$3FFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFFF,c0)<>$3FFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(-$3FFFFFFF,c31)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFFF,c31)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(-c3FFFFFFF,31)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(c3FFFFFFF,31)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint(-$3FFFFFFF)<>-$20000000 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3FFFFFFF)<>$1FFFFFFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 writeln;

 writeln('Testing SarSmallint...');
 if SarSmallint(-$3FFF,c4)<>-$400 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FFF,c4)<>$3FF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(-$3FF0,c4)<>-$3FF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FF0,c4)<>$3FF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(-$3FFF,c0)<>-$3FFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FFF,c0)<>$3FFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(-$3FFF,c15)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FFF,c15)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(-c3FFF,15)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(c3FFF,15)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint(-$3FFF)<>-$2000 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3FFF)<>$1FFF then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 writeln;

 writeln('Testing SarShortint...');
 if SarShortint(-$3F,c4)<>-$4 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3F,c4)<>$3 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(-$30,c4)<>-$3 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($30,c4)<>$3 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(-$3F,c0)<>-$3F then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3F,c0)<>$3F then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(-$3F,c7)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(c3F,7)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(-c3F,7)<>-1 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3F,c7)<>0 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint(-$3F)<>-$20 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3F)<>$1F then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 writeln;


 { the overflow behaviour is different for different CPUs
 writeln('Testing shifting overflows');
 if SarInt64($3fffffffffffffff,c68)<>$3ffffffffffffff then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarLongint($3fffffff,c36)<>$3ffffff then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarSmallint($3fff,c20)<>$3ff then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 if SarShortint($3f,c12)<>$3 then begin
  halt(1);
 end else begin
  writeln('Pass!');
 end;
 }

 writeln('All passed');
end.
beefree / fpc-src deb

Products

About

Resources

Contact Gemfury
