paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-06 14:10:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

# revisions: 40850,41429,43188,43281,43282,43283,43801

Browse Source 
git-svn-id: branches/fixes_3_2@44301 -
This commit is contained in:
marco 2020-03-14 16:08:36 +00:00
parent 7b1408640e
commit 626c2b52c0
7 changed files with 257 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -17558,6 +17558,7 @@ tests/webtbs/tw3474.pp svneol=native#text/plain
tests/webtbs/tw3477.pp svneol=native#text/plain
tests/webtbs/tw3478.pp svneol=native#text/plain
tests/webtbs/tw3479.pp svneol=native#text/plain
tests/webtbs/tw34848.pp svneol=native#text/pascal
tests/webtbs/tw3489.pp svneol=native#text/plain
tests/webtbs/tw3490.pp svneol=native#text/plain
tests/webtbs/tw3491.pp svneol=native#text/plain
@ -17569,6 +17570,7 @@ tests/webtbs/tw35027.pp svneol=native#text/pascal
tests/webtbs/tw35028.pp svneol=native#text/pascal
tests/webtbs/tw3504.pp svneol=native#text/plain
tests/webtbs/tw3506.pp svneol=native#text/plain
tests/webtbs/tw35136.pp svneol=native#text/pascal
tests/webtbs/tw35139.pp svneol=native#text/plain
tests/webtbs/tw35139a.pp svneol=native#text/plain
tests/webtbs/tw35149.pp svneol=native#text/plain
@ -17581,6 +17583,7 @@ tests/webtbs/tw3540.pp svneol=native#text/plain
tests/webtbs/tw3546.pp svneol=native#text/plain
tests/webtbs/tw35533.pp svneol=native#text/pascal
tests/webtbs/tw3554.pp svneol=native#text/plain
tests/webtbs/tw35626.pp -text svneol=native#text/pascal
tests/webtbs/tw3564.pp svneol=native#text/plain
tests/webtbs/tw3567.pp svneol=native#text/plain
tests/webtbs/tw3572.pp svneol=native#text/plain
@ -17683,6 +17686,7 @@ tests/webtbs/tw4058.pp svneol=native#text/plain
tests/webtbs/tw4068.pp svneol=native#text/plain
tests/webtbs/tw4078.pp svneol=native#text/plain
tests/webtbs/tw4080.pp svneol=native#text/plain
tests/webtbs/tw40850.pp svneol=native#text/pascal
tests/webtbs/tw4086.pp svneol=native#text/plain
tests/webtbs/tw4089.pp svneol=native#text/plain
tests/webtbs/tw4093.pp svneol=native#text/plain

88
rtl/inc/iso7185.pp
View File

@ -47,9 +47,23 @@ unit iso7185;
Procedure Get(Var f: TypedFile);
Procedure Put(Var f: TypedFile);
Procedure Seek(var f:TypedFile;Pos:Int64);
Function FilePos(var f:TypedFile):Int64;
Function Eof(var f:TypedFile): Boolean;
{$ifdef FPC_CURRENCY_IS_INT64}
{$ifndef FPUNONE}
function round(c : currency) : int64;
{$endif FPUNONE}
{$ifndef cpujvm}
function round(c : comp) : int64;
{$else not cpujvm}
function round_comp(c : comp) : int64;
{$endif not cpujvm}
{$endif FPC_CURRENCY_IS_INT64}
function Round(d : ValReal) : int64;
implementation
@ -130,7 +144,7 @@ unit iso7185;
else
begin
OldCtrlZMarksEof:=CtrlZMarksEOF;
CtrlZMarksEof:=false;
CtrlZMarksEof:=true;
Eof:=System.Eof(t);
CtrlZMarksEof:=OldCtrlZMarksEOF;
end;
@ -193,13 +207,13 @@ unit iso7185;
procedure Get(var f:TypedFile);[IOCheck];
Begin
if not(eof(f)) then
BlockRead(f,(pbyte(@f)+sizeof(FileRec))^,1)
BlockRead(f,(pbyte(@f)+sizeof(FileRec))^,1);
End;
Procedure Put(var f:TypedFile);[IOCheck];
begin
BlockWrite(f,(pbyte(@f)+sizeof(FileRec))^,1)
BlockWrite(f,(pbyte(@f)+sizeof(FileRec))^,1);
end;
@ -208,6 +222,74 @@ unit iso7185;
Eof:=FileRec(f)._private[1]=1;
End;
Procedure Seek(var f:TypedFile;Pos:Int64);[IOCheck];
Begin
System.Seek(f,Pos);
if (FileRec(f).mode=fmInOut) or
(FileRec(f).mode=fmInput) then
begin
if FilePos(f)<FileSize(f) then
begin
FileRec(f)._private[1]:=0;
Get(f);
end
else
FileRec(f)._private[1]:=1;
end;
End;
Function FilePos(var f:TypedFile):Int64;[IOCheck];
Begin
FilePos:=System.FilePos(f);
{ in case of reading a file, the buffer is always filled, so the result of Do_FilePos is off by one }
if (FileRec(f).mode=fmInOut) or
(FileRec(f).mode=fmInput) then
dec(FilePos);
End;
{$ifdef FPC_CURRENCY_IS_INT64}
{$ifndef FPUNONE}
function round(c : currency) : int64;
begin
if c>=0.0 then
Round:=Trunc(c+0.5)
else
Round:=Trunc(c-0.5);
end;
{$endif FPUNONE}
{$ifndef cpujvm}
function round(c : comp) : int64;
begin
if c>=0.0 then
round:=Trunc(c+0.5)
else
round:=Trunc(c-0.5);
end;
{$else not cpujvm}
function round_comp(c : comp) : int64;
begin
if c>=0.0 then
round_comp:=Trunc(c+0.5)
else
round_comp:=Trunc(c-0.5);
end;
{$endif cpujvm}
{$endif FPC_CURRENCY_IS_INT64}
function Round(d : ValReal) : int64;
begin
if d>=0.0 then
Round:=Trunc(d+0.5)
else
Round:=Trunc(d-0.5);
end;
begin
{ we shouldn't do this because it might confuse user programs, but for now it
is good enough to get pretty unique tmp file names }

2
rtl/inc/text.inc
View File

@ -1858,6 +1858,8 @@ procedure fpc_Read_Text_Char_intern(var f : Text; out c: char); iocheck; [extern
function fpc_GetBuf_Text(var f : Text) : pchar; iocheck; compilerproc;
Begin
Result:=@TextRec(f).Bufptr^[TextRec(f).BufEnd];
if TextRec(f).mode=fmOutput then
exit;
If not CheckRead(f) then
exit;
If TextRec(f).BufPos>=TextRec(f).BufEnd Then

41
tests/webtbs/tw34848.pp Normal file
View File

@ -0,0 +1,41 @@
{$mode iso}
program mytest;
procedure my_test1;
type byte_file = file of byte;
var test_file : byte_file;
test_text : text;
loc : integer;
len : integer;
my_bits : byte;
pos : int64;
begin
assign(test_text, 'tw34848.data');
rewrite(test_text);
write(test_text,'0123456789'#10);
close(test_text);
loc := 9;
assign(test_file, 'tw34848.data');
reset(test_file);
len := filesize(test_file);
writeln('File size: ', len);
seek(test_file, loc);
if EOF(test_file) then
writeln('EOF reached');
pos := filepos(test_file);
writeln('File position: ', pos);
read(test_file, my_bits);
writeln(my_bits);
if my_bits<>57 then
halt(1);
read(test_file, my_bits);
writeln(my_bits);
if my_bits<>10 then
halt(1);
close(test_file);
end;
begin
my_test1;
writeln('ok');
end.

16
tests/webtbs/tw35136.pp Normal file
View File

@ -0,0 +1,16 @@
{ %opt=-Miso }
program p;
var f: text;
begin
rewrite(f);
f^ := 'a';
put(f);
reset(f);
if eof(f) then writeln('premature eof');
writeln(f^);
if eof(f) then writeln('premature eof');
writeln(f^);
if eof(f) then writeln('premature eof');
get(f);
if eof(f) then writeln('eof correctly set') else begin writeln('eof should be set, but isn''t'); halt(1); end;
end.

66
tests/webtbs/tw35626.pp Normal file
View File

@ -0,0 +1,66 @@
program RoundFunctionTest(output);
{$MODE ISO}
{ Expected result }
{ FPC result in accordance with ISO 7185 }
{ ---------- --------------------------- }
begin
writeln('Testing the round() function with positive numbers:');
writeln('round(0.5) = ', round(0.5)); { 0 1 }
if round(0.5)<>1 then
halt(1);
writeln('round(1.5) = ', round(1.5)); { 2 2 }
if round(1.5)<>2 then
halt(1);
writeln('round(2.5) = ', round(2.5)); { 2 3 }
if round(2.5)<>3 then
halt(1);
writeln('round(3.5) = ', round(3.5)); { 4 4 }
if round(3.5)<>4 then
halt(1);
writeln('round(4.5) = ', round(4.5)); { 4 5 }
if round(4.5)<>5 then
halt(1);
writeln('round(5.5) = ', round(5.5)); { 6 6 }
if round(5.5)<>6 then
halt(1);
writeln('round(10.5) = ', round(10.5)); { 10 11 }
if round(10.5)<>11 then
halt(1);
writeln('round(11.5) = ', round(11.5)); { 12 12 }
if round(11.5)<>12 then
halt(1);
writeln('round(12.5) = ', round(12.5)); { 12 13 }
if round(12.5)<>13 then
halt(1);
writeln;
writeln('Testing the round() function with negative numbers:');
writeln('round(-0.5) = ', round(-0.5)); { 0 -1 }
if round(-0.5)<>-1 then
halt(1);
writeln('round(-1.5) = ', round(-1.5)); { -2 -2 }
if round(-1.5)<>-2 then
halt(1);
writeln('round(-2.5) = ', round(-2.5)); { -2 -3 }
if round(-2.5)<>-3 then
halt(1);
writeln('round(-3.5) = ', round(-3.5)); { -4 -4 }
if round(-3.5)<>-4 then
halt(1);
writeln('round(-4.5) = ', round(-4.5)); { -4 -5 }
if round(-4.5)<>-5 then
halt(1);
writeln('round(-5.5) = ', round(-5.5)); { -6 -6 }
if round(-5.5)<>-6 then
halt(1);
writeln('round(-10.5) = ', round(-10.5)); { -10 -11 }
if round(-10.5)<>-11 then
halt(1);
writeln('round-(11.5) = ', round(-11.5)); { -12 -12 }
if round(-11.5)<>-12 then
halt(1);
writeln('round(-12.5) = ', round(-12.5)); { -12 -13 }
if round(-12.5)<>-13 then
halt(1);
writeln
end.

43
tests/webtbs/tw40850.pp Normal file
View File

@ -0,0 +1,43 @@
{$mode iso}
program mytest;
procedure my_test1;
type byte_file = file of byte;
var test_file : byte_file;
test_text : text;
loc : integer;
len : integer;
my_bits : byte;
pos : int64;
begin
assign(test_text, 'tw40850.data');
rewrite(test_text);
write(test_text,'0123456789'#10);
close(test_text);
loc := 9;
assign(test_file, 'tw40850.data');
reset(test_file);
len := filesize(test_file);
writeln('File size: ', len);
seek(test_file, loc);
if EOF(test_file) then
writeln('EOF reached');
pos := filepos(test_file);
if pos<>9 then
halt(1);
writeln('File position: ', pos);
read(test_file, my_bits);
if my_bits<>57 then
halt(1);
writeln(my_bits);
read(test_file, my_bits);
writeln(my_bits);
if my_bits<>10 then
halt(1);
close(test_file);
writeln('ok');
end;
begin
my_test1;
end.