paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-19 10:09:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Implements some more Delphi compatible functions in ConvUtils unit, resolves

Browse Source 
bug #39773

(cherry picked from commit b0b034805c)
This commit is contained in:
marcoonthegit 2022-06-10 10:38:14 +02:00
parent 9b59a5ede5
commit 3faa984635
1 changed files with 72 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -68,9 +68,14 @@ function ConvUnitDec(const AValue: Double; const AType, AAmountType: TConvType):
function ConvUnitInc(const AValue: Double; const AType: TConvType; function ConvUnitInc(const AValue: Double; const AType: TConvType;
const AAmount: Double; const AAmountType: TConvType): TConvUtilFloat; const AAmount: Double; const AAmountType: TConvType): TConvUtilFloat;
function ConvUnitInc(const AValue: Double; const AType, AAmountType: TConvType): TConvUtilFloat; function ConvUnitInc(const AValue: Double; const AType, AAmountType: TConvType): TConvUtilFloat;
function ConvUnitWithinNext(const AValue, ATest: Double; const AType: TConvType;
const AAmount: Double; const AAmountType: TConvType): Boolean;
function ConvUnitWithinPrevious(const AValue, ATest: Double;
const AType: TConvType; const AAmount: Double; const AAmountType: TConvType): Boolean;
function ConvFamilyToDescription(const AFamily: TConvFamily): string; function ConvFamilyToDescription(const AFamily: TConvFamily): string;
function ConvTypeToDescription(const AType: TConvType): string; function ConvTypeToDescription(const AType: TConvType): string;
function ConvUnitToStr(const AValue: Double; const AType: TConvType): string;
function DescriptionToConvFamily(const ADescription: String; out AFamily: TConvFamily): Boolean; function DescriptionToConvFamily(const ADescription: String; out AFamily: TConvFamily): Boolean;
function DescriptionToConvType(const ADescription: String; out AType: TConvType): Boolean; overload; function DescriptionToConvType(const ADescription: String; out AType: TConvType): Boolean; overload;
function DescriptionToConvType(const AFamily: TConvFamily; const ADescription: String; out AType: TConvType): Boolean; overload; function DescriptionToConvType(const AFamily: TConvFamily; const ADescription: String; out AType: TConvType): Boolean; overload;
@ -78,9 +83,14 @@ procedure GetConvFamilies(out AFamilies: TConvFamilyArray);
procedure GetConvTypes(const AFamily: TConvFamily; out ATypes: TConvTypeArray); procedure GetConvTypes(const AFamily: TConvFamily; out ATypes: TConvTypeArray);
function ConvTypeToFamily(const AType: TConvType): TConvFamily; function ConvTypeToFamily(const AType: TConvType): TConvFamily;
function ConvTypeToFamily(const AFrom, ATo: TConvType): TConvFamily;
function CompatibleConversionType(const AType: TConvType; const AFamily: TConvFamily): Boolean; function CompatibleConversionType(const AType: TConvType; const AFamily: TConvFamily): Boolean;
function CompatibleConversionTypes(const AFrom, ATo: TConvType): Boolean; function CompatibleConversionTypes(const AFrom, ATo: TConvType): Boolean;
procedure RaiseConversionError(const AText: string);
procedure RaiseConversionError(const AText: string; const AArgs: array of const);
procedure RaiseConversionRegError(AFamily: TConvFamily; const ADescription: string);
Type Type
TConvTypeInfo = Class(Tobject) TConvTypeInfo = Class(Tobject)
private private
@ -124,6 +134,8 @@ Implementation
uses uses
RtlConsts; RtlConsts;
const macheps=1E-9;
Type ResourceData = record Type ResourceData = record
Description : String; Description : String;
Value : TConvUtilFloat; Value : TConvUtilFloat;
@ -168,6 +180,32 @@ begin
result:=ConvUnitInc(AValue, AType, 1.0, AAmountType); result:=ConvUnitInc(AValue, AType, 1.0, AAmountType);
end; end;
function ConvUnitWithinNext(const AValue, ATest: Double;
const AType: TConvType; const AAmount: Double; const AAmountType: TConvType): Boolean;
var
D: Double;
begin
D:=Convert(AAmount, AAMountType, AType);
//don't use InRange() since it does have an epsilon parameter
result:=(CompareValue(ATest,AValue,macheps)<>LessThanValue) and
(CompareValue(ATest,AValue+D,macheps)<>GreaterThanValue);
end;
function ConvUnitWithinPrevious(const AValue, ATest: Double;
const AType: TConvType; const AAmount: Double; const AAmountType: TConvType): Boolean;
var
D: Double;
begin
D:=Convert(AAmount, AAMountType, AType);
result:=(CompareValue(ATest,AValue,macheps)<>GreaterThanValue) and
(CompareValue(ATest,AValue-D,macheps)<>LessThanValue);
end;
function ConvFamilyToDescription(const AFamily: TConvFamily): string; function ConvFamilyToDescription(const AFamily: TConvFamily): string;
begin begin
@ -176,6 +214,12 @@ begin
result:=TheFamilies[AFamily]; result:=TheFamilies[AFamily];
end; end;
function ConvUnitToStr(const AValue: Double; const AType: TConvType): string;
begin
result:=format(GConvUnitToStrFmt,[AValue,ConvTypeToDescription(AType)]);
end;
function DescriptionToConvFamily(const ADescription: String; out AFamily: TConvFamily): Boolean; function DescriptionToConvFamily(const ADescription: String; out AFamily: TConvFamily): Boolean;
var var
i: Integer; i: Integer;
@ -269,6 +313,16 @@ begin
result:=TheUnits[AType].Fam; result:=TheUnits[AType].Fam;
end; end;
function ConvTypeToFamily(const AFrom, ATo: TConvType): TConvFamily;
begin
result:=ConvTypeToFamily(AFrom);
if result<>CIllegalConvFamily then begin
if ConvTypeToFamily(ATo)<>result then
result:=CIllegalConvFamily;
end;
end;
function CompatibleConversionType(const AType: TConvType; function CompatibleConversionType(const AType: TConvType;
const AFamily: TConvFamily): Boolean; const AFamily: TConvFamily): Boolean;
@ -313,7 +367,6 @@ begin
Result:=i<Length(TheFamilies); Result:=i<Length(TheFamilies);
end; end;
const macheps=1E-9;
Function InternalRegisterConversionType(Fam:TConvFamily;Const S:String;Value:TConvUtilFloat; Function InternalRegisterConversionType(Fam:TConvFamily;Const S:String;Value:TConvUtilFloat;
const AToCommonFunc, AFromCommonFunc: TConversionProc):TConvType; const AToCommonFunc, AFromCommonFunc: TConversionProc):TConvType;
@ -477,6 +530,24 @@ begin
result:=ConvUnitAdd(AVAlue1, ATYpe1, -AValue2, AType2, AResultType); result:=ConvUnitAdd(AVAlue1, ATYpe1, -AValue2, AType2, AResultType);
end; end;
procedure RaiseConversionError(const AText: string);
begin
Raise EConversionError.Create(AText);
end;
procedure RaiseConversionError(const AText: string; const AArgs: array of const);
begin
Raise EConversionError.CreateFmt(AText, AArgs);
end;
procedure RaiseConversionRegError(AFamily: TConvFamily; const ADescription: string);
begin
Raise EConversionError.CreateFmt(SConvDuplicateType,[ADescription,ConvFamilyToDescription(AFamily)]);
end;
Constructor TConvTypeInfo.Create(Const AConvFamily : TConvFamily;const ADescription:String); Constructor TConvTypeInfo.Create(Const AConvFamily : TConvFamily;const ADescription:String);
begin begin