2

2 つの Real48 (6 バイト float) を比較する次のコードは、コンパイルして実行しますが、無意味な結果を生成するか、AV を生成します。

program Project44;

{$APPTYPE CONSOLE}
uses
  System.SysUtils,
  System.Generics.Defaults;

begin
  try
    WriteLn(System.Generics.Defaults.TComparer<Real48>.Default.Compare(100.0,100.0));
    WriteLn('all ok, press space');
  except on E:exception do
    WriteLn(e.Message);
  end;
  ReadLn
end.

0 を出力するはずですが、最初に爆撃しないと出力-92するか、その他の誤った値が出力されます。

このバグは最新の XE8 にも存在しますか?
もしそうなら、それは以前に報告されましたか? https://quality.embarcadero.comでは何も見つかりませんが、古い QC があればそれを参照したいと思います。

REAL48最後に....を使用して2つのタイプを比較するにはどうすればよいTComparer<something>ですか?

編集：
これは私が解決した修正でした：

interface
...snip...
[Test]
procedure TestReal48;
...snip...  
    TTest<T> = record
  private
    class var Def: System.Generics.Defaults.IComparer<T>;
    class var F: FastDefaults.TComparison<T>;
  public
    class function Real48Comparison(const Left, Right: T): Integer; static;

implementation

procedure TestDefault.TestReal48;
var
  OldDef: System.Generics.Defaults.IComparer<Real48>;
begin
  OldDef:= TTest<Real48>.Def;
  TTest<Real48>.Def:= System.Generics.Defaults.TComparer<Real48>.Construct(TTest<Real48>.Real48Comparison);
  TTest<Real48>.Test(100.0,100.0);
  TTest<Real48>.Test(100000.0,-10000.0);
  TTest<Real48>.Test(0.0,-10000.0);
  TTest<Real48>.Test(100000.0,0.0);
  TTest<Real48>.Test(0.0,0.0);
  TTest<Real48>.Def:= OldDef;
end;
4

1 に答える 1

6

この欠陥は、コンパイラのすべてのバージョンに存在します。Real48は 10 年以上前に廃止されたため、バグ レポートを提出したとしても、Embarcadero は動作を変更しないと予想されます。もちろん、引き続きバグ レポートを送信する必要がありますが、修正を待っているときに息を止めません。

デフォルトに依存するのではなく、比較子を作成する必要があります。

var
  Comparer: IComparer<Real48>;

function Real48Comparison(const Left, Right: Real48): Integer;
begin
  if Left < Right then
    Result := -1
  else if Left > Right then
    Result := 1
  else
    Result := 0;
end;

Comparer := System.Generics.Defaults.TComparer<Real48>.Construct(Real48Comparison);

なぜデフォルトのReal48比較子はそれほど失敗するのですか? さて、それはここから始まります：

class function TComparer<T>.Default: IComparer<T>;
begin
  Result := IComparer<T>(_LookupVtableInfo(giComparer, TypeInfo(T), SizeOf(T)));
end;

ということが発生しTypeInfo(Real48)ますnil。の型情報がないようですReal48。おそらく大きな驚きではありません。

次に、ここに到達します。

function _LookupVtableInfo(intf: TDefaultGenericInterface; info: PTypeInfo; size: Integer): Pointer;
var
  pinfo: PVtableInfo;
begin
  if info <> nil then
  begin
    pinfo := @VtableInfo[intf, info^.Kind];
    Result := pinfo^.Data;
    if ifSelector in pinfo^.Flags then
      Result := TTypeInfoSelector(Result)(info, size);
    if ifVariableSize in pinfo^.Flags then
      Result := MakeInstance(Result, size);
  end
  else
  begin
    case intf of
      giComparer: Result := Comparer_Selector_Binary(info, size);
      giEqualityComparer: Result := EqualityComparer_Selector_Binary(info, size);
    else
      System.Error(reRangeError);
      Result := nil;
    end;
  end;
end;

elseブランチを取り、を呼び出しますComparer_Selector_Binary。したがって、バイナリ比較を実行することになります。比較は実際には次の関数によって実行されます。

function Compare_Binary(Inst: PSimpleInstance; const Left, Right): Integer;
begin
  Result := BinaryCompare(@Left, @Right, Inst^.Size);
end;

これは次を呼び出します：

function BinaryCompare(const Left, Right: Pointer; Size: Integer): Integer;
var
  pl, pr: PByte;
  len: Integer;
begin
  pl := Left;
  pr := Right;
  len := Size;
  while len > 0 do
  begin
    Result := pl^ - pr^;
    if Result <> 0 then
      Exit;
    Dec(len);
    Inc(pl);
    Inc(pr);
  end;
  Result := 0;
end;

実数値型には役に立ちません。

の ABI に関連するランタイム エラーについては、Real48. Real48パラメータは常にスタック上で渡されるようです。これは、 での型指定されていないパラメーターの使用と互換性がありませんCompare_Binary。

于 2015-06-10T11:12:40.273 に答える