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

svn+ssh://[email protected]/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: branches/fixes_2_2@11033 -

.gitattributes

@@ -671,8 +671,6 @@ ide/test1.pas svneol=native#text/plain
 ide/test2.pas svneol=native#text/plain
 ide/tpgrep.tdf -text
 ide/unit.pt -text
-ide/utils/grep2msg.pas svneol=native#text/plain
-ide/utils/tphc.pas svneol=native#text/plain
 ide/vesa.pas svneol=native#text/plain
 ide/wansi.pas svneol=native#text/plain
 ide/wcedit.pas svneol=native#text/plain
@@ -8001,6 +7999,8 @@ tests/webtbs/tw1124.pp svneol=native#text/plain
 tests/webtbs/tw11254.pp svneol=native#text/plain
 tests/webtbs/tw11288.pp svneol=native#text/plain
 tests/webtbs/tw11290.pp svneol=native#text/plain
+tests/webtbs/tw11308.pp svneol=native#text/plain
+tests/webtbs/tw11309.pp svneol=native#text/plain
 tests/webtbs/tw11312.pp svneol=native#text/plain
 tests/webtbs/tw1132.pp svneol=native#text/plain
 tests/webtbs/tw1133.pp svneol=native#text/plain

.gitignore

@@ -187,13 +187,6 @@ ide/fakegdb/fpcmade.*
 ide/fakegdb/units
 ide/fpcmade.*
 ide/units
-ide/utils/*.bak
-ide/utils/*.exe
-ide/utils/*.o
-ide/utils/*.ppu
-ide/utils/*.s
-ide/utils/fpcmade.*
-ide/utils/units
 installer/*.bak
 installer/*.exe
 installer/*.o

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;

ide/utils/grep2msg.pas

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

ide/utils/tphc.pas

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

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);

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

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.

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.

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}

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);

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