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

* patch from Bart to fix convutils temperature fix.

Browse Source 
(cherry picked from commit 7ddeaa54c0)
This commit is contained in:
marcoonthegit 2022-06-05 18:51:52 +02:00
parent ba7a8ff709
commit 229d9f89ae
2 changed files with 65 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -39,6 +39,7 @@ Type TConvType = type Integer;
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;
function Convert ( const Measurement : Double; const FromType, ToType : TConvType ) :TConvUtilFloat;
function Convert ( const Measurement : Double; const FromType1, FromType2, ToType1, ToType2 : TConvType ) :TConvUtilFloat;
@ -99,9 +100,11 @@ uses
RtlConsts;
Type ResourceData = record
Description : String;
Value : TConvUtilFloat;
Fam : TConvFamily;
Description : String;
Value : TConvUtilFloat;
ToCommonFunc : TConversionProc;
FromCommonFunc: TConversionProc;
Fam : TConvFamily;
end;
@ -242,7 +245,8 @@ end;
const macheps=1E-9;
Function RegisterConversionType(Fam:TConvFamily;Const S:String;Value:TConvUtilFloat):TConvType;
Function InternalRegisterConversionType(Fam:TConvFamily;Const S:String;Value:TConvUtilFloat;
const AToCommonFunc, AFromCommonFunc: TConversionProc):TConvType;
var l1 : Longint;
@ -255,10 +259,23 @@ begin
Setlength(theunits,l1+1);
theunits[l1].description:=s;
theunits[l1].value:=value;
theunits[l1].ToCommonFunc:=AToCommonFunc;
theunits[l1].FromCommonFunc:=AFromCommonFunc;
theunits[l1].fam:=fam;
Result:=l1;
end;
Function RegisterConversionType(Fam:TConvFamily;Const S:String;Value:TConvUtilFloat):TConvType;
begin
InternalRegisterConversionType(Fam,S,Value,nil,nil);
end;
function RegisterConversionType(Fam: TConvFamily; const S: String;
const AToCommonFunc, AFromCommonFunc: TConversionProc): TConvType;
begin
InternalRegisterConversionType(Fam,S,(AToCommonFunc(1)-AToCommonFunc(0)),AToCommonFunc,AFromCommonFunc);
end;
function SearchConvert(TheType:TConvType; var r:ResourceData):Boolean;
var l1 : longint;
@ -275,6 +292,7 @@ function Convert ( const Measurement : Double; const FromType, ToType : TConvT
var
fromrec,torec : resourcedata;
common: double;
begin
if not SearchConvert(fromtype,fromrec) then
@ -286,7 +304,17 @@ begin
ConvFamilyToDescription(fromrec.fam),
ConvFamilyToDescription(torec.fam)
]);
result:=Measurement*fromrec.value/torec.value;
if assigned(fromrec.ToCommonFunc) or assigned(torec.FromCommonFunc) then begin
if assigned(fromrec.ToCommonFunc) then
common:=fromrec.ToCommonFunc(MeasureMent)
else
common:=Measurement*fromrec.value;
if assigned(torec.FromCommonFunc) then
result:=torec.FromCommonFunc(common)
else
result:=common/torec.value;
end else
result:=Measurement*fromrec.value/torec.value;
end;
function Convert ( const Measurement : Double; const FromType1, FromType2, ToType1, ToType2 : TConvType ) :TConvUtilFloat;
@ -310,6 +338,7 @@ begin
ConvFamilyToDescription(fromrec2.fam),
ConvFamilyToDescription(torec2.fam)
]);
//using ToCommonFunc() and FromCommonFunc makes no sense in this context
result:=Measurement*(fromrec1.value/fromrec2.value)/(torec1.value/torec2.value);
end;

20
packages/rtl-objpas/src/inc/stdconvs.pp
View File

@ -227,6 +227,9 @@ function CelsiusToFahrenheit(const AValue: Double): Double;
function FahrenheitToCelsius(const AValue: Double): Double;
function CelsiusToKelvin (const AValue: Double): Double;
function KelvinToCelsius (const AValue: Double): Double;
function RankineToCelsius (const AValue: Double): Double;
function CelsiusToRankine (const AValue: Double): Double;
implementation
@ -250,6 +253,17 @@ begin
result:=AValue-273.15;
end;
function RankineToCelsius(const AValue: Double): Double;
begin
result:=(AValue*Double(5/9))-273.15;
end;
function CelsiusToRankine(const AValue: Double): Double;
begin
result:=(AValue+273.15)*1.8;
end;
ResourceString // Note, designations for FFU's are guesses.
txtauSquareMillimeters = 'Square millimeters (mm^2)';
@ -474,9 +488,9 @@ end;
procedure RegisterTemperature;
begin
tuCelsius := RegisterConversionType(cbTemperature,txttuCelsius,1);
tuKelvin := RegisterConversionType(cbTemperature,txttuKelvin,1);
tuFahrenheit := RegisterConversionType(cbTemperature,txttuFahrenheit,5/9);
tuRankine := RegisterConversionType(cbTemperature,txttuRankine,0.5555556);
tuKelvin := RegisterConversionType(cbTemperature,txttuKelvin,@KelvinToCelsius,@CelsiusToKelvin);
tuFahrenheit := RegisterConversionType(cbTemperature,txttuFahrenheit,@FahrenheitToCelsius,@CelsiusToFahrenheit);
tuRankine := RegisterConversionType(cbTemperature,txttuRankine,@RankineToCelsius,@CelsiusToRankine);
tuReamur := RegisterConversionType(cbTemperature,txttuReamur,10/8); // Reaumur?
end;