paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 15:29:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: currency, overload distance for intdouble and uintdouble

Browse Source 
git-svn-id: trunk@35931 -
This commit is contained in:
Mattias Gaertner 2017-04-24 10:56:40 +00:00
parent 34f547d0d4
commit 793622e3c9
2 changed files with 52 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
packages/fcl-passrc/src/pasresolver.pp
View File

@ -354,7 +354,7 @@ type
btDouble, // double 5.0E-324..1.7E308, digits 15-16, bytes 8
btExtended, // extended platform, double or 1.9E-4932..1.1E4932, digits 19-20, bytes 10
btCExtended, // cextended
btCurrency, // currency -2E64+1 .. 2E63-1, bytes 8
btCurrency, // as int64, but least 4 digits are the decimals (*10000), bytes 8
btBoolean, // boolean
btByteBool, // bytebool true=not zero
btWordBool, // wordbool true=not zero
@ -372,7 +372,7 @@ type
btIntDouble, // integer range of double 53bit
btQWord, // qword 0..18446744073709551615, bytes 8
btInt64, // int64 -9223372036854775808..9223372036854775807, bytes 8
btComp, // comp -2E64+1..2E63-1, digits 19-20, bytes 8
btComp, // as Int64 but not ordinal
btPointer, // pointer
btFile, // file
btText, // text
@ -386,12 +386,12 @@ type
TResolveBaseTypes = set of TResolverBaseType;
const
btAllInteger = [btByte,btShortInt,btWord,btSmallInt,btIntSingle,btUIntSingle,
btLongWord,btLongint,btIntDouble,btUIntDouble,btQWord,btInt64];
btLongWord,btLongint,btIntDouble,btUIntDouble,btQWord,btInt64,btComp];
btAllChars = [btChar,btAnsiChar,btWideChar];
btAllStrings = [btString,btAnsiString,btShortString,
btWideString,btUnicodeString,btRawByteString];
btAllStringAndChars = btAllStrings+btAllChars;
btAllFloats = [btSingle,btDouble,btExtended,btCExtended,btCurrency,btComp];
btAllFloats = [btSingle,btDouble,btExtended,btCExtended,btCurrency];
btAllBooleans = [btBoolean,btByteBool,btWordBool,btLongBool,btQWordBool];
btAllStandardTypes = [
btChar,
@ -478,6 +478,14 @@ const
'range..'
);
const
MinSafeIntCurrency = -922337203685477;
MaxSafeIntCurrency = 922337203685477;
MinSafeIntSingle = -16777216;
MaxSafeIntSingle = 16777216;
MinSafeIntDouble = -$10000000000000;
MaxSafeIntDouble = $fffffffffffff;
type
TResolverBuiltInProc = (
bfCustom,
@ -1456,6 +1464,7 @@ type
function GetCombinedBoolean(Bool1, Bool2: TResolverBaseType; ErrorEl: TPasElement): TResolverBaseType; virtual;
function GetCombinedInt(const Int1, Int2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
procedure GetIntegerProps(bt: TResolverBaseType; out Precision: word; out Signed: boolean);
function GetIntegerRange(bt: TResolverBaseType; out MinVal, MaxVal: int64): boolean;
function GetIntegerBaseType(Precision: word; Signed: boolean; ErrorEl: TPasElement): TResolverBaseType;
function GetCombinedChar(const Char1, Char2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
function GetCombinedString(const Str1, Str2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
@ -1506,7 +1515,6 @@ procedure SetResolverValueExpr(out ResolvedType: TPasResolverResult;
Flags: TPasResolverResultFlags); overload;
function ProcNeedsImplProc(Proc: TPasProcedure): boolean;
function GetIntegerRange(bt: TResolverBaseType; out MinVal, MaxVal: int64): boolean;
function dbgs(const Flags: TPasResolverComputeFlags): string; overload;
function dbgs(const a: TResolvedRefAccess): string;
@ -1778,25 +1786,6 @@ begin
Result:=false;
end;
function GetIntegerRange(bt: TResolverBaseType; out MinVal, MaxVal: int64
): boolean;
begin
Result:=true;
case bt of
btByte: begin MinVal:=Low(byte); MaxVal:=High(byte); end;
btShortInt: begin MinVal:=low(ShortInt); MaxVal:=high(ShortInt); end;
btWord: begin MinVal:=low(word); MaxVal:=high(word); end;
btSmallInt: begin MinVal:=low(SmallInt); MaxVal:=high(SmallInt); end;
btLongWord: begin MinVal:=low(LongWord); MaxVal:=high(LongWord); end;
btLongint: begin MinVal:=low(LongInt); MaxVal:=high(LongInt); end;
btInt64,btExtended,btComp: begin MinVal:=low(int64); MaxVal:=high(int64); end;
btSingle: begin MinVal:=-16777216; MaxVal:=16777216; end;
btDouble: begin MinVal:=-$10000000000000; MaxVal:=$fffffffffffff; end;
else
Result:=false;
end;
end;
function dbgs(const Flags: TPasResolverComputeFlags): string;
var
s: string;
@ -9815,7 +9804,7 @@ begin
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btLongWord,btLongint,btUIntDouble]) then
inc(Result,cLossyConversion);
btQWord,
btInt64:
btInt64,btComp:
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btUIntSingle,btIntSingle,
btLongWord,btLongint,btUIntDouble,btIntDouble]) then
inc(Result,cLossyConversion);
@ -9829,23 +9818,26 @@ begin
Result:=cToFloatConversion+ord(LBT)-ord(RBT);
case LBT of
btSingle:
if not (RBT in [btByte,btShortInt,btWord,btSmallInt]) then
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,
btIntSingle,btUIntSingle]) then
inc(Result,cLossyConversion);
btDouble:
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btLongWord,
btLongint,btSingle]) then
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,
btIntSingle,btUIntSingle,btSingle,
btLongWord,btLongint,
btIntDouble,btUIntDouble]) then
inc(Result,cLossyConversion);
btExtended,btCExtended:
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btLongWord,
btLongint,btInt64,btComp,btSingle,btDouble]) then
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,
btIntSingle,btUIntSingle,btSingle,
btLongWord,btLongint,
btInt64,btComp,
btIntDouble,btUIntDouble,btDouble]) then
inc(Result,cLossyConversion);
btCurrency:
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btLongWord,
btLongint,btSingle]) then
inc(Result,cLossyConversion);
btComp:
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btLongWord,
btLongint,btSingle]) then
if not (RBT in [btByte,btShortInt,btWord,btSmallInt,
btIntSingle,btUIntSingle,
btLongWord,btLongint]) then
inc(Result,cLossyConversion);
else
RaiseNotYetImplemented(20170417205910,ErrorEl,BaseTypeNames[LBT]);
@ -12115,12 +12107,35 @@ begin
btIntDouble: begin Precision:=53; Signed:=true; end;
btUIntDouble: begin Precision:=52; Signed:=false; end;
btQWord: begin Precision:=64; Signed:=false; end;
btInt64: begin Precision:=64; Signed:=true; end;
btInt64,btComp: begin Precision:=64; Signed:=true; end;
else
RaiseInternalError(20170420095727);
end;
end;
function TPasResolver.GetIntegerRange(bt: TResolverBaseType; out MinVal,
MaxVal: int64): boolean;
begin
Result:=true;
if bt=btExtended then bt:=BaseTypeExtended;
case bt of
btByte: begin MinVal:=Low(byte); MaxVal:=High(byte); end;
btShortInt: begin MinVal:=low(ShortInt); MaxVal:=high(ShortInt); end;
btWord: begin MinVal:=low(word); MaxVal:=high(word); end;
btSmallInt: begin MinVal:=low(SmallInt); MaxVal:=high(SmallInt); end;
btLongWord: begin MinVal:=low(LongWord); MaxVal:=high(LongWord); end;
btLongint: begin MinVal:=low(LongInt); MaxVal:=high(LongInt); end;
btInt64,btComp: begin MinVal:=low(int64); MaxVal:=high(int64); end;
btSingle,btIntSingle: begin MinVal:=MinSafeIntSingle; MaxVal:=MaxSafeIntSingle; end;
btUIntSingle: begin MinVal:=0; MaxVal:=MaxSafeIntSingle; end;
btDouble,btIntDouble: begin MinVal:=MinSafeIntDouble; MaxVal:=MaxSafeIntDouble; end;
btUIntDouble: begin MinVal:=0; MaxVal:=MaxSafeIntDouble; end;
btCurrency: begin MinVal:=MinSafeIntCurrency; MaxVal:=MaxSafeIntCurrency; end;
else
Result:=false;
end;
end;
function TPasResolver.GetIntegerBaseType(Precision: word; Signed: boolean;
ErrorEl: TPasElement): TResolverBaseType;
begin

17
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -369,7 +369,6 @@ type
Procedure TestClassAssign;
Procedure TestClassNilAsParam;
Procedure TestClass_Operators_Is_As;
Procedure TestClass_OperatorIsOnNonDescendantFail;
Procedure TestClass_OperatorIsOnNonTypeFail;
Procedure TestClass_OperatorAsOnNonDescendantFail;
Procedure TestClass_OperatorAsOnNonTypeFail;
@ -5384,22 +5383,6 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestClass_OperatorIsOnNonDescendantFail;
begin
StartProgram(false);
Add('type');
Add(' {#TOBJ}TObject = class');
Add(' end;');
Add(' {#A}TClassA = class');
Add(' end;');
Add('var');
Add(' {#o}{=TOBJ}o: TObject;');
Add(' {#v}{=A}v: TClassA;');
Add('begin');
Add(' if {@v}v is {@TObj}TObject then;');
CheckResolverException(sTypesAreNotRelated,PasResolver.nTypesAreNotRelated);
end;
procedure TTestResolver.TestClass_OperatorIsOnNonTypeFail;
begin
StartProgram(false);