Merged revisions 11019,11022,11025-11026 via svnmerge from

svn+ssh://jonas@svn.freepascal.org/FPC/svn/fpc/trunk

........
r11019 | florian | 2008-05-19 22:20:01 +0200 (Mon, 19 May 2008) | 2 lines

- removed directory with non-working sources as well with copyrighted sources

........
r11022 | jonas | 2008-05-21 17:03:31 +0200 (Wed, 21 May 2008) | 3 lines

  * also consider jump tables embedded in the code when calculating the
    distance between a jump and its target

........
r11025 | jonas | 2008-05-21 18:55:31 +0200 (Wed, 21 May 2008) | 9 lines

  * use rounding correction in str_real based on smallest possible
    delta for which 1.0 and 1.0+delta is different, rather than
    some power-of-10 ballpark equivalent (fixes mantis #11308)
  * print the same number of digits for doubles on systems
    which support extended as on those which don't (i.e.,
    one digit less on the former). This solves regressions after
    the previous change and is Delphi-compatible.
  * adapted tests for the previous change

........
r11026 | jonas | 2008-05-21 19:06:41 +0200 (Wed, 21 May 2008) | 2 lines

  + test for already fixed mantis #11309

........


git-svn-id: http://svn.freepascal.org/svn/fpc/branches/fixes_2_2@11033 3ad0048d-3df7-0310-abae-a5850022a9f2

10 files changed, 91 insertions, 339 deletions

diff --git a/compiler/ppcgen/aasmcpu.pas b/compiler/ppcgen/aasmcpu.pas
index 522ffe7c24..83a5971fd9 100644
--- a/compiler/ppcgen/aasmcpu.pas
+++ b/compiler/ppcgen/aasmcpu.pas
@@ -504,8 +504,17 @@ uses cutils, cclasses;
                   labelpositions.count := tai_label(p).labsym.labelnr * 2;
                 labelpositions[tai_label(p).labsym.labelnr] := pointer(instrpos);
               end;
-            if p.typ = ait_instruction then
-              inc(instrpos);
+            { ait_const is for jump tables }
+            case p.typ of
+              ait_instruction:
+                inc(instrpos);
+              ait_const:
+                begin
+                  if (tai_const(p).consttype<>aitconst_32bit) then
+                    internalerror(2008052101); 
+                  inc(instrpos);
+                end;
+            end;
             p := tai(p.next);
           end;
 
@@ -571,6 +580,8 @@ uses cutils, cclasses;
                           end;
                     end;
                   end;
+                ait_const:
+                  inc(instrpos);
               end;
               p := tai(p.next);
             end;
diff --git a/ide/utils/grep2msg.pas b/ide/utils/grep2msg.pas
deleted file mode 100644
index bb1a61c519..0000000000
--- a/ide/utils/grep2msg.pas
+++ /dev/null
@@ -1,101 +0,0 @@
-{************************************************}
-{                                                }
-{   Grep message filter example                  }
-{   Copyright (c) 1992 by Borland International  }
-{                                                }
-{************************************************}
-
-program Grep2Msg;
-
-{ Message filters read input from the target program (in this case, GREP)
-  by way of StdIn (by using Read or ReadLn), filter the input, then write
-  output back to StdOut (using Write or WriteLn). The IDE takes care of
-  redirecting the transfer program's output to the filter program, as well
-  as redirecting the filter program's output back to the IDE itself.
-}
-
-{$I-,S-}
-
-var
-  LineNo, E: Word;
-  P1,P2: integer;
-  Line: String;
-  InputBuffer: array[0..4095] of Char;
-  OutputBuffer: array[0..4095] of Char;
-
-
-{ The first data passed back to the IDE by a message filter must always
-  be the string 'BI#PIP#OK', followed by a null terminator.
-}
-procedure WriteHeader;
-begin
-  Write('BI#PIP#OK'#0);
-end;
-
-{ The beginning of a new file is marked by a #0, the file's name, terminated
-  by a #0 character.
-}
-procedure WriteNewFile(const FileName: String);
-begin
-  Write(#0, FileName, #0);
-end;
-
-{ Each message line begins with a #1, followed the line number (in low/high
-  order), followed by the column number (in low/high order), then the
-  message text itself, terminated with a #0 character.
-}
-procedure WriteMessage(Line, Col: Word; const Message: String);
-begin
-  Write(#1, Chr(Lo(Line)), Chr(Hi(Line)), Chr(Lo(Col)), Chr(Hi(Col)),
-    Message, #0);
-end;
-
-{ The end of the input stream is marked by a #127 character }
-procedure WriteEnd;
-begin
-  Write(#127);
-end;
-
-function TrimLeft(S:String): String;
-var
-  i: Integer;
-  n: String;
-begin
-  i := 1;
-  while (i <= Length(s)) and (s[i] = #32) do Inc(i);
-  if i <= Length(s) then
-  begin
-    Move(s[i], n[1], Length(s) - i + 1);
-    n[0] := Char(Length(s) - i + 1);
-  end
-  else n[0] := #0;
-  TrimLeft := n;
-end;
-
-const LastFileName: string = '';
-
-begin
-  SetTextBuf(Input, InputBuffer);
-  SetTextBuf(Output, OutputBuffer);
-  WriteHeader;
-  while not Eof do
-  begin
-    ReadLn(Line);
-    if Line <> '' then
-    begin
-      P1:=Pos(':',Line);
-      if copy(Line, 1, P1)<>LastFileName then
-        begin
-          LastFileName:=copy(Line,1,P1-1);
-          WriteNewFile(LastFileName);
-        end;
-      P2:=Pos(':',copy(Line,P1+1,255));
-      if P2>0 then
-      begin
-        Val(Copy(Line, P1+1, P2-1), LineNo, E);
-        if E = 0 then WriteMessage(LineNo, 1, TrimLeft(Copy(Line, P1+1+P2, 132)));
-      end;
-    end;
-  end;
-  WriteEnd;
-end.
diff --git a/ide/utils/tphc.pas b/ide/utils/tphc.pas
deleted file mode 100644
index c819aec93e..0000000000
--- a/ide/utils/tphc.pas
+++ /dev/null
@@ -1,208 +0,0 @@
-{
- !!! Someone please fix DRIVERS.PAS, so it doesn't clears the screen on exit
-     when we didn't use any of it's functions, just had it in 'uses'
-
-     Then we can delete GetDosTicks() from WHelp...
-}
-
-uses Objects,WUtils,WHelp,WTPHWriter;
-
-const
-     SrcExt          = '.txt';
-     HelpExt         = '.fph';
-     TokenPrefix     = '.';
-     CommentPrefix   = ';';
-     TokenIndex      = 'INDEX';
-     TokenTopic      = 'TOPIC';
-     TokenCode       = 'CODE';
-
-     FirstTempTopic  = 1000000;
-
-     CR              = #$0D;
-     LF              = #$0A;
-
-type
-     THCIndexEntry = record
-       Tag      : PString;
-       TopicName: PString;
-     end;
-
-     THCTopic = record
-       Name     : PString;
-       Topic    : PTopic;
-     end;
-
-     PHCIndexEntryCollection = ^THCIndexEntryCollection;
-     THCIndexEntryCollection = object(T
-
-var SrcName, DestName: string;
-    HelpFile        : THelpFileWriter;
-
-procedure Print(const S: string);
-begin
-  writeln(S);
-end;
-
-procedure Abort; forward;
-
-procedure Help;
-begin
-  Print('Syntax : TPHC <helpsource>[.TXT] <helpfile>[.FPH]');
-  Abort;
-end;
-
-procedure Fatal(const S: string);
-begin
-  Print('Fatal: '+S);
-  Abort;
-end;
-
-procedure Warning(const S: string);
-begin
-  Print('Warning: '+S);
-end;
-
-procedure ProcessParams;
-begin
-  if (ParamCount<1) or (ParamCount>2) then Help;
-  SrcName:=ParamStr(1);
-  if ExtOf(SrcName)='' then SrcName:=SrcName+SrcExt;
-  if ParamCount=1 then
-    DestName:=DirAndNameOf(SrcName)+HelpExt
-  else
-    begin
-      DestName:=ParamStr(2);
-      if ExtOf(DestName)='' then DestName:=DestName+HelpExt;
-    end;
-end;
-
-procedure Compile(SrcS, DestS: PStream);
-var CurLine: string;
-    CurLineNo: longint;
-    CurTopic : PTopic;
-    HelpFile: PHelpFileWriter;
-    InCode: boolean;
-    NextTempTopic: longint;
-procedure AddLine(const S: string);
-begin
-  if CurTopic<>nil then
-    HelpFile^.AddLineToTopic(CurTopic,S);
-end;
-procedure ProcessToken(S: string);
-var P: byte;
-    Token: string;
-    TopicName: string;
-    TopicContext: THelpCtx;
-    Text: string;
-begin
-  S:=Trim(S);
-  P:=Pos(' ',S); if P=0 then P:=length(S)+1;
-  Token:=UpcaseStr(copy(S,1,P-1)); Delete(S,1,P); S:=Trim(S);
-  if Token=TokenIndex then
-    begin
-      if InCode then AddLine(hscCode);
-      if copy(S,1,1)<>'{' then
-        Fatal('"{" expected at line '+IntToStr(CurLineNo));
-      if copy(S,length(S),1)<>'}' then
-        Fatal('"}" expected at line '+IntToStr(CurLineNo));
-      S:=copy(S,2,length(S)-2);
-      P:=Pos(':',S); if P=0 then P:=length(S)+1;
-      Text:=copy(S,1,!!
-    end else
-  if Token=TokenTopic then
-    begin
-      if InCode then AddLine(hscCode);
-      P:=Pos(' ',S); if P=0 then P:=length(S)+1;
-      TopicName:=UpcaseStr(copy(S,1,P-1)); Delete(S,1,P); S:=Trim(S);
-      if TopicName='' then
-        Fatal('Topic name missing at line '+IntToStr(CurLineNo));
-      if S='' then
-        TopicContext:=0
-      else
-        if copy(S,1,1)<>'=' then
-          begin
-            Fatal('"=" expected at line '+IntToStr(CurLineNo));
-            TopicContext:=0;
-          end
-        else
-          begin
-            S:=Trim(copy(S,2,255));
-            TopicContext:=StrToInt(S);
-            if LastStrToIntResult<>0 then
-              Fatal('Error interpreting context number at line '+IntToStr(CurLineNo));
-          end;
-      if TopicContext=0 then
-        begin
-          TopicContext:=NextTempTopic;
-          Inc(NextTempTopic);
-        end;
-      CurTopic:=HelpFile^.CreateTopic(TopicContext);
-    end else
-  if Token=TokenCode then
-    begin
-      AddLine(hscCode);
-      InCode:=not InCode;
-    end else
-  Warning('Uknown token "'+Token+'" encountered at line '+IntToStr(CurLineNo));
-end;
-procedure ProcessLine(const S: string);
-begin
-  AddLine(S);
-end;
-function ReadNextLine: boolean;
-var C: char;
-begin
-  Inc(CurLineNo);
-  CurLine:='';
-  repeat
-    SrcS^.Read(C,1);
-    if (C in[CR,LF])=false then
-      CurLine:=CurLine+C;
-  until (C=LF) or (SrcS^.Status<>stOK);
-  ReadNextLine:=(SrcS^.Status=stOK);
-end;
-var OK: boolean;
-begin
-  New(HelpFile, InitStream(DestS,0));
-  CurTopic:=nil; CurLineNo:=0;
-  NextTempTopic:=FirstTempTopic;
-  InCode:=false;
-  repeat
-    OK:=ReadNextLine;
-    if OK then
-    if copy(CurLine,1,length(CommentPrefix))=CommentPrefix then
-      { comment }
-    else
-    if copy(CurLine,1,length(TokenPrefix))=TokenPrefix then
-      ProcessToken(copy(CurLine,2,255))
-    else
-    { normal help-text }
-    begin
-      ProcessLine(CurLine);
-    end;
-  until OK=false;
-  if HelpFile^.WriteFile=false then
-    Fatal('Error writing help file.');
-  Dispose(HelpFile, Done);
-end;
-
-const SrcS  : PBufStream = nil;
-      DestS : PBufStream = nil;
-
-procedure Abort;
-begin
-  if SrcS<>nil then Dispose(SrcS, Done); SrcS:=nil;
-  if DestS<>nil then Dispose(DestS, Done); DestS:=nil;
-end;
-
-BEGIN
-  Print('þ Help Compiler  Version 0.9  Copyright (c) 1999 by B‚rczi G bor');
-  ProcessParams;
-  New(SrcS, Init(SrcName, stOpenRead, 4096));
-  if (SrcS=nil) or (SrcS^.Status<>stOK) then
-    Fatal('Error opening source file.');
-  New(DestS, Init(DestName, stCreate, 4096));
-  if (DestS=nil) or (DestS^.Status<>stOK) then
-    Fatal('Error creating destination file.');
-  Compile(SrcS,DestS);
-END.
diff --git a/rtl/inc/real2str.inc b/rtl/inc/real2str.inc
index d66d4c6dd2..7c33f5fdb9 100644
--- a/rtl/inc/real2str.inc
+++ b/rtl/inc/real2str.inc
@@ -173,7 +173,7 @@ const
         { the fractional part is not used for rounding later                }
         currprec := -1;
         { instead, round based on the next whole digit }
-        if (int(intPartStack[stackPtr]-corrVal) > 5.0 - roundCorr) then
+        if (int(intPartStack[stackPtr]-corrVal+roundcorr) >= 5.0) then
            roundStr(temp,spos);
         end;
 {$ifdef DEBUG_NASM}
@@ -189,24 +189,13 @@ begin
          minlen:=8;
          explen:=4;
          { correction used with comparing to avoid rounding/precision errors }
-         roundCorr := (1/exp((16-4-3)*ln(10)));
+         roundCorr := 1.1920928955e-07;
       end;
     rt_s64real :
       begin
-{ if the maximum supported type is double, we can print out one digit }
-{ less, because otherwise we can't round properly and 1e-400 becomes   }
-{ 0.99999999999e-400 (JM)                                              }
-{$ifdef support_extended}
-         maxlen:=23;
-         { correction used with comparing to avoid rounding/precision errors }
-         roundCorr := (1/exp((23-5-3)*ln(10)));
-{$else support_extended}
-{$ifdef support_double}
          maxlen := 22;
          { correction used with comparing to avoid rounding/precision errors }
-         roundCorr := (1/exp((22-4-3)*ln(10)));
-{$endif support_double}
-{$endif support_extended}
+         roundCorr := 2.2204460493e-16;
          minlen:=9;
          explen:=5;
       end;
@@ -217,7 +206,7 @@ begin
          minlen:=10;
          explen:=6;
          { correction used with comparing to avoid rounding/precision errors }
-         roundCorr := (1/exp((25-6-3)*ln(10)));
+         roundCorr := 1.0842021725e-19;
       end;
     rt_c64bit  :
       begin
@@ -226,7 +215,7 @@ begin
          { according to TP (was 5) (FK) }
          explen:=6;
          { correction used with comparing to avoid rounding/precision errors }
-         roundCorr := (1/exp((23-6-3)*ln(10)));
+         roundCorr := 2.2204460493e-16;
       end;
     rt_currency :
       begin
@@ -235,7 +224,7 @@ begin
          minlen:=10;
          explen:=0;
          { correction used with comparing to avoid rounding/precision errors }
-         roundCorr := (1/exp((25-6-3)*ln(10)));
+         roundCorr := 1.0842021725e-19;
       end;
     rt_s128real  :
       begin
@@ -244,7 +233,7 @@ begin
          minlen:=10;
          explen:=6;
          { correction used with comparing to avoid rounding/precision errors }
-         roundCorr := (1/exp((25-6-3)*ln(10)));
+         roundCorr := 1.0842021725e-19;
       end;
     end;
   { check parameters }
@@ -378,12 +367,13 @@ begin
           for fracCount := 1 to currPrec do
             factor := factor * 10.0;
           corrval := corrval / factor;
-          if d >= corrVal-roundCorr then
+          d:=d+roundCorr;
+          if d >= corrVal then
             d := d + corrVal;
-          if int(d+roundCorr) = 1 then
+          if int(d) = 1 then
             begin
               roundStr(temp,spos);
-              d := frac(d+roundCorr);
+              d := frac(d);
               if (f < 0) then
                 begin
                   dec(currprec);
@@ -397,7 +387,7 @@ begin
           { calculate the necessary fractional digits }
           for fracCount := 1 to currPrec do
             begin
-              if d > 1.0- roundCorr then
+              if d > 1.0 then
                 d := frac(d) * 10.0
               else d := d * 10.0;
               inc(spos);
diff --git a/tests/test/cg/tstr.pp b/tests/test/cg/tstr.pp
index ba859755ed..d445ff9d44 100644
--- a/tests/test/cg/tstr.pp
+++ b/tests/test/cg/tstr.pp
@@ -68,7 +68,7 @@ begin
   str(f,s);
   if (sizeof(extended) = 10) or
      (sizeof(extended) = 12) then
-    check('-1.123450000000000E+000')
+    check('-1.12345000000000E+000')
   else if sizeof(extended) = 8 then
     check('-1.12345000000000E+000')
   else
@@ -252,7 +252,7 @@ begin
   str(f,s);
   if (sizeof(extended) = 10) or
      (sizeof(extended) = 12) then
-    check('-1.123450000000000E+000')
+    check('-1.12345000000000E+000')
   else if sizeof(extended) = 8 then
     check('-1.12345000000000E+000')
   else
@@ -436,7 +436,7 @@ begin
 {$IFOPT E-}
   str(f,s);
   if sizeof(extended) = 10 then
-    check('-1.123450000000000E+000')
+    check('-1.12345000000000E+000')
   else if sizeof(extended) = 8 then
     check('-1.12345000000000E+000')
   else
diff --git a/tests/webtbs/tw11308.pp b/tests/webtbs/tw11308.pp
new file mode 100644
index 0000000000..6560ed303f
--- /dev/null
+++ b/tests/webtbs/tw11308.pp
@@ -0,0 +1,17 @@
+uses
+  sysutils;
+
+var
+  s: string;
+begin
+  str(1.575:0:2,s);
+  writeln(s);
+  if (s<>'1.58') then
+    halt(1);
+  str(0.575:0:2,s);
+  writeln(s);
+  if (s<>'0.58') then
+    halt(2);
+//  writeln(FloatToStrF(1.575 ,ffFixed,19,2));
+//  writeln(FloatToStrF(0.575 ,ffFixed,19,2));
+end.
diff --git a/tests/webtbs/tw11309.pp b/tests/webtbs/tw11309.pp
new file mode 100644
index 0000000000..fc0231c0dc
--- /dev/null
+++ b/tests/webtbs/tw11309.pp
@@ -0,0 +1,43 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+uses
+  SysUtils;
+
+const
+  csMoney = '58.195';
+
+Function Format_Currency_String1(sMoney : string) : string;
+var
+aCurrency : Currency;
+begin
+  TRY
+aCurrency := strtoCurr(sMoney);
+  EXCEPT
+   on E: EConvertError do aCurrency := 0;
+  END;
+//result := CurrToStrF(currBetrag,ffFixed,2);
+result := FloatToStrF(aCurrency,ffFixed,19,2);
+end;
+
+Function Format_Currency_String2(sMoney : string) : string;
+var
+aCurrency : real;
+begin
+  TRY
+aCurrency := strtofloat(sMoney);
+  EXCEPT
+   on E: EConvertError do aCurrency := 0;
+  END;
+result := FloatToStrF(aCurrency,ffFixed,19,2);
+end;
+
+begin
+  writeln(Format_Currency_String1(csMoney));
+  writeln(Format_Currency_String2(csMoney));
+  if Format_Currency_String1(csMoney)<>'58.20' then
+    halt(1);
+  if Format_Currency_String2(csMoney)<>'58.20' then
+    halt(2);
+end.
diff --git a/tests/webtbs/tw1792a.pp b/tests/webtbs/tw1792a.pp
index c2ba829c0e..ea3a4aca1f 100644
--- a/tests/webtbs/tw1792a.pp
+++ b/tests/webtbs/tw1792a.pp
@@ -15,7 +15,7 @@ Begin
 {$ifdef FPC_HAS_TYPE_DOUBLE}
  str(double(intpower(2,63)),s);
 {$ifdef FPC_HAS_TYPE_EXTENDED}
- if s<>' 9.223372036854776E+018' then
+ if s<>' 9.22337203685478E+018' then
 {$else FPC_HAS_TYPE_EXTENDED}
  if s<>' 9.22337203685478E+018' then
 {$endif FPC_HAS_TYPE_EXTENDED}
diff --git a/tests/webtbs/tw2226.pp b/tests/webtbs/tw2226.pp
index 0012a69868..85618a576d 100644
--- a/tests/webtbs/tw2226.pp
+++ b/tests/webtbs/tw2226.pp
@@ -10,7 +10,7 @@ var
   correct : string;
 begin
   case sizeof(extended) of
-    10: correct := '                   -Inf';
+    10: correct := '                  -Inf';
     8: correct := '                  -Inf';
   end;
   str(mindouble,s);
diff --git a/tests/webtbs/tw2643.pp b/tests/webtbs/tw2643.pp
index 205ef82fd4..2b395f7da8 100644
--- a/tests/webtbs/tw2643.pp
+++ b/tests/webtbs/tw2643.pp
@@ -21,7 +21,7 @@ begin
      end;
    str(d,s);
    if sizeof(extended) > 8 then
-     s1 := ' 5.168568500000000E+006'
+     s1 := ' 5.16856850000000E+006'
    else
      s1 := ' 5.16856850000000E+006';
    if s<>s1 then