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

git-svn-id: branches/fixes_3_2@44301 -

.gitattributes

@@ -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

rtl/inc/iso7185.pp

@@ -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 }

rtl/inc/text.inc

@@ -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

tests/webtbs/tw34848.pp

@@ -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.

tests/webtbs/tw35136.pp

@@ -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.

tests/webtbs/tw35626.pp

@@ -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.

tests/webtbs/tw40850.pp

@@ -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.