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

* Patch from Bart, Fix issue #39778

Browse Source 
(cherry picked from commit 480199a7d9)
This commit is contained in:
Michaël Van Canneyt 2022-06-13 10:10:36 +02:00 committed by marcoonthegit
parent 3a8b807c20
commit a672c527d4
1 changed files with 169 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

214
packages/rtl-objpas/src/inc/convutil.inc
View File

@ -46,6 +46,9 @@ Function RegisterConversionFamily(Const S : String):TConvFamily;
Function RegisterConversionType(Fam:TConvFamily;Const S:String;Value:TConvUtilFloat):TConvType;
Function RegisterConversionType(Fam:TConvFamily;Const S:String;const AToCommonFunc, AFromCommonFunc: TConversionProc): TConvType;
procedure UnregisterConversionFamily(const AFamily: TConvFamily);
procedure UnregisterConversionType(const AType: TConvType);
function Convert ( const Measurement : Double; const FromType, ToType : TConvType ) :TConvUtilFloat;
function Convert ( const Measurement : Double; const FromType1, FromType2, ToType1, ToType2 : TConvType ) :TConvUtilFloat;
@ -79,6 +82,9 @@ function ConvUnitToStr(const AValue: Double; const AType: TConvType): string;
function DescriptionToConvFamily(const ADescription: String; out AFamily: TConvFamily): Boolean;
function DescriptionToConvType(const ADescription: String; out AType: TConvType): Boolean; overload;
function DescriptionToConvType(const AFamily: TConvFamily; const ADescription: String; out AType: TConvType): Boolean; overload;
function TryStrToConvUnit(AText: string; out AValue: Double; out AType: TConvType): Boolean;
function StrToConvUnit(AText: string; out AType: TConvType): Double;
procedure GetConvFamilies(out AFamilies: TConvFamilyArray);
procedure GetConvTypes(const AFamily: TConvFamily; out ATypes: TConvTypeArray);
@ -142,11 +148,61 @@ Type ResourceData = record
ToCommonFunc : TConversionProc;
FromCommonFunc: TConversionProc;
Fam : TConvFamily;
Deleted : Boolean;
end;
TFamilyData = record
Description: String;
Deleted : Boolean;
end;
var TheUnits : array of ResourceData =nil;
TheFamilies : array of string =nil;
TheFamilies : array of TFamilyData =nil;
function FindFamily(const ADescription: String; out AFam: TConvFamily): Boolean;
var
i: Integer;
begin
result:=False;
for i := 0 to Length(TheFamilies)-1 do
begin
if (TheFamilies[i].Description=ADescription) and (not TheFamilies[i].Deleted) then
begin
result:=True;
AFam:=TConvFamily(i);
Exit;
end;
end;
end;
function FindConvType(AFam: TConvFamily; const ADescription: string; out AResourceData: ResourceData): Boolean;
var
i: Integer;
begin
result:=False;
for i := 0 to Length(TheUnits)-1 do
begin
if (TheUnits[i].Fam=AFam) and (TheUnits[i].Description=ADescription) and (not TheUnits[i].Deleted) then
begin
result:=True;
AResourceData:=TheUnits[i];
end;
end;
end;
function FindConvType(AFam: TConvFamily; const ADescription: string): Boolean;
var
Data: ResourceData;
begin
result:=FindConvType(AFam, ADescription, Data);
end;
function ConvUnitDec(const AValue: Double; const AType: TConvType;
const AAmount: Double; const AAmountType: TConvType): TConvUtilFloat;
@ -209,8 +265,8 @@ end;
function ConvFamilyToDescription(const AFamily: TConvFamily): string;
begin
if AFamily<length(TheFamilies) then
result:=TheFamilies[AFamily]
if (AFamily<length(TheFamilies)) and not (TheFamilies[AFamily].Deleted) then
result:=TheFamilies[AFamily].Description
else
result:=format(SConvUnknownDescriptionWithPrefix,['$',AFamily]);
end;
@ -228,7 +284,7 @@ begin
Result := False;
for i := 0 to Length(TheFamilies) - 1 do
begin
if TheFamilies[i] = ADescription then
if (TheFamilies[i].Description=ADescription) and not TheFamilies[i].Deleted then
begin
AFamily := i;
Result := true;
@ -239,11 +295,20 @@ end;
procedure GetConvFamilies(out AFamilies: TConvFamilyArray);
var i : integer;
var i , count: integer;
begin
AFamilies:=nil;
setlength(AFamilies,length(thefamilies));
count:=0;
for i:=0 to length(TheFamilies)-1 do
AFamilies[i]:=i;
begin
if not TheFamilies[i].Deleted then
begin
AFamilies[i]:=i;
Inc(Count);
end;
end;
SetLength(AFamilies,count);
end;
procedure GetConvTypes(const AFamily: TConvFamily; out ATypes: TConvTypeArray);
@ -252,13 +317,14 @@ var i,j,nrTypes:integer;
begin
nrTypes:=0;
ATypes:=nil;
for i:=0 to length(TheUnits)-1 do
if TheUnits[i].fam=AFamily Then
inc(nrTypes);
if (TheUnits[i].fam=AFamily) and (not TheUnits[i].Deleted) and (not TheUnits[i].Deleted) Then
inc(nrTypes);
setlength(atypes,nrtypes);
j:=0;
for i:=0 to length(TheUnits)-1 do
if TheUnits[i].fam=AFamily Then
if (TheUnits[i].fam=AFamily) and (not TheUnits[i].Deleted) and (not TheUnits[i].Deleted) Then
begin
atypes[j]:=i;
inc(j);
@ -270,7 +336,7 @@ end;
function TryConvTypeToDescription(const AType: TConvType; out S: string): Boolean;
begin
result:=AType<length(TheUnits);
result:=(AType<length(TheUnits)) and (not TheUnits[AType].Deleted);
if result then
S:=TheUnits[AType].Description;
end;
@ -289,7 +355,7 @@ begin
Result := False;
for i := 0 to Length(TheUnits) - 1 do
begin
if TheUnits[i].Description = ADescription then
if (TheUnits[i].Description = ADescription) and (not TheUnits[i].Deleted) then
begin
AType := i;
Result := true;
@ -306,7 +372,8 @@ begin
for i := 0 to Length(TheUnits) - 1 do
begin
if (AFamily = TheUnits[i].Fam) and
(TheUnits[i].Description = ADescription) then
(TheUnits[i].Description = ADescription) and
(not TheUnits[i].Deleted) then
begin
AType := i;
Result := true;
@ -315,17 +382,41 @@ begin
end;
end;
function TryStrToConvUnit(AText: string; out AValue: Double; out AType: TConvType): Boolean;
var
P: SizeInt;
ValueStr, TypeStr: String;
Data: ResourceData;
begin
Result:=False;
P:=Pos(#32,AText);
if P=0 then
Exit;
ValueStr:=Copy(AText,1,P);
if not TryStrToFloat(ValueStr, AValue) then
Exit;
while AText[P]=#32 do Inc(P);
TypeStr:=Copy(AText,P,MaxInt);
Result:=DescriptionToConvType(TypeStr, AType);
end;
function StrToConvUnit(AText: string; out AType: TConvType): Double;
begin
if not TryStrToConvUnit(AText, Result, AType) then
raise EConversionError.CreateFmt(SConvStrParseError,[AText]);
end;
//since a conversion family actually can have any (including an empty) description we need a function that
//properly checks and indicates wether or not AType actually exists
function TryConvTypeToFamily(const AType: TConvType; out AFam: TConvFamily): Boolean;
var
Fam: TConvFamily;
begin
result:=false;
if AType<length(TheUnits) then begin
Fam:=TheUnits[AType].Fam;
if (AType<length(TheUnits)) and (not TheUnits[AType].Deleted) then begin
AFam:=TheUnits[AType].Fam;
result:=true;
end;
end;
@ -367,42 +458,56 @@ function CompatibleConversionTypes(const AFrom, ATo: TConvType): Boolean;
begin
//ConvTypeToFamily potentially raises an exception, make sure it doesn't here
result:= (AFrom<length(TheUnits)) and (ATo<length(TheUnits)) and
(not TheUnits[AFrom].Deleted) and (not TheUnits[ATo].Deleted) and
(ConvTypeToFamily(AFrom)=ConvTypeToFamily(ATo));
end;
Function RegisterConversionFamily(Const S:String):TConvFamily;
var i,l : Longint;
var len : Longint;
fam: TConvFamily;
begin
l:=Length(TheFamilies);
If l=0 Then
begin
SetLength(TheFamilies,1);
TheFamilies[0]:=S;
Result:=0;
end
else
begin
if l=Integer(High(TConvFamily)) then
raise EConversionError.CreateFmt(SConvTooManyConvFamilies,[High(TConvFamily)]);
i:=0;
while (i<l) and (s<>TheFamilies[i]) do inc(i);
if i=l Then
begin
SetLength(TheFamilies,l+1);
TheFamilies[l]:=s;
end;
Result:=i;
end;
len:=Length(TheFamilies);
if len>0 then
if FindFamily(S, fam) then
raise EConversionError.CreateFmt(SConvDuplicateFamily,[S]);
if len=Integer(High(TConvFamily))+1 then
raise EConversionError.CreateFmt(SConvTooManyConvFamilies,[High(TConvFamily)]);
SetLength(TheFamilies,len+1);
TheFamilies[len].Description:=S;
TheFamilies[len].Deleted:=False;
result:=len;
end;
procedure UnregisterConversionFamily(const AFamily: TConvFamily);
var
i: Integer;
begin
//Apparently this procedure is not supposed to raise exceptions
TheFamilies[AFamily].Deleted:=True;
for i:=0 to Length(TheUnits)-1 do
begin
if TheUnits[i].Fam=AFamily then
TheUnits[i].Deleted:=True;
end;
end;
Function CheckFamily(i:TConvFamily):Boolean;
begin
Result:=i<Length(TheFamilies);
Result:=(i<Length(TheFamilies)) and (not TheFamilies[i].Deleted);
end;
procedure UnregisterConversionType(const AType: TConvType);
begin
//Apparently this procedure is not supposed to raise exceptions
if AType<Length(TheUnits) then
TheUnits[AType].Deleted:=True;
end;
Function InternalRegisterConversionType(Fam:TConvFamily;Const S:String;Value:TConvUtilFloat;
const AToCommonFunc, AFromCommonFunc: TConversionProc):TConvType;
@ -413,7 +518,10 @@ begin
If NOT CheckFamily(Fam) Then
raise EConversionError.CreateFmt(SConvUnknownFamily, [IntToStr(Fam)]);
l1:=length(theunits);
if l1=Integer(High(TConvType)) then
if l1>0 then
if FindConvType(Fam, S) then
raise EConversionError.CreateFmt(SConvDuplicateType,[S,ConvFamilyToDescription(Fam)]);
if l1=Integer(High(TConvType))+1 then
raise EConversionError.CreateFmt(SConvTooManyConvTypes,[High(TConvType)]);
Setlength(theunits,l1+1);
theunits[l1].description:=s;
@ -421,6 +529,7 @@ begin
theunits[l1].ToCommonFunc:=AToCommonFunc;
theunits[l1].FromCommonFunc:=AFromCommonFunc;
theunits[l1].fam:=fam;
theunits[l1].deleted:=false;
Result:=l1;
end;
@ -435,13 +544,13 @@ begin
result:=InternalRegisterConversionType(Fam,S,(AToCommonFunc(1)-AToCommonFunc(0)),AToCommonFunc,AFromCommonFunc);
end;
function SearchConvert(TheType:TConvType; var r:ResourceData):Boolean;
function SearchConvert(TheType:TConvType; out r:ResourceData):Boolean;
var l1 : longint;
begin
l1:=length(TheUnits);
if thetype>=l1 then
if (thetype>=l1) or (theunits[thetype].Deleted) then
exit(false);
r:=theunits[thetype];
result:=true;
@ -470,10 +579,17 @@ begin
common:=Measurement*fromrec.value;
if assigned(torec.FromCommonFunc) then
result:=torec.FromCommonFunc(common)
else
else begin
if IsZero(torec.value) then
raise EZeroDivide.CreateFmt(SConvFactorZero,[torec.Description]);
result:=common/torec.value;
end else
end;
end else begin
//Note: Delphi 7 raises an EZeroDivide even if fromrec.value=0, which is a bit odd
if IsZero(torec.value) then
raise EZeroDivide.CreateFmt(SConvFactorZero,[torec.Description]);
result:=Measurement*fromrec.value/torec.value;
end;
end;
function Convert ( const Measurement : Double; const FromType1, FromType2, ToType1, ToType2 : TConvType ) :TConvUtilFloat;
@ -498,6 +614,10 @@ begin
ConvFamilyToDescription(torec2.fam)
]);
//using ToCommonFunc() and FromCommonFunc makes no sense in this context
if IsZero(fromrec2.value) then
raise EZeroDivide.CreateFmt(SConvFactorZero,[fromrec2.Description]);
if IsZero(torec2.value) then
raise EZeroDivide.CreateFmt(SConvFactorZero,[torec2.Description]);
result:=Measurement*(fromrec1.value/fromrec2.value)/(torec1.value/torec2.value);
end;
@ -526,7 +646,11 @@ begin
if Assigned(torec.FromCommonFunc) then
result:=torec.FromCommonFunc(AValue)
else
begin
if IsZero(torec.value) then
raise EZeroDivide.CreateFmt(SConvFactorZero,[torec.Description]);
result:=Avalue/torec.value;
end;
end;
function ConvUnitCompareValue(const AValue1: Double; const AType1: TConvType;
@ -544,7 +668,7 @@ end;
function ConvUnitSameValue(const AValue1: Double; const AType1: TConvType;
const AValue2: Double; const AType2: TConvType): Boolean;
begin
result:=ConvUnitCompareValue(Avalue1, AType1, AValue2, AType2)=0;
result:=ConvUnitCompareValue(Avalue1, AType1, AValue2, AType2)=EqualsValue;
end;