pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity

v3.i

Browse Source 
git-svn-id: https://svn.code.sf.net/p/kolmck/code@78 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck
2010-10-12 17:54:18 +00:00
parent bbd0e2aee6
commit 19cb111bcd
6 changed files with 1314 additions and 433 deletions
Download Patch File Download Diff File Expand all files Collapse all files

89
Addons/KOLMath.pas
View File

@ -12,9 +12,8 @@
Key Objects Library (C) 2000 by Kladov Vladimir. Key Objects Library (C) 2000 by Kladov Vladimir.
mailto: bonanzas@xcl.cjb.net mailto: vk@kolmck.net
Home: http://bonanzas.rinet.ru Home: http://kolmck.net
http://xcl.cjb.net
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
{ {
@ -49,7 +48,7 @@ unit kolmath;
interface interface
uses err, kol; uses {$IFNDEF MATH_NOERR} err, {$ENDIF} kol;
const { Ranges of the IEEE floating point types, including denormals } const { Ranges of the IEEE floating point types, including denormals }
MinSingle = 1.5e-45; MinSingle = 1.5e-45;
@ -408,10 +407,12 @@ type
const const
MaxIterations = 15; MaxIterations = 15;
{$IFNDEF MATH_NOERR}
procedure ArgError(const Msg: string); procedure ArgError(const Msg: string);
begin begin
raise Exception.Create(e_Math_InvalidArgument, Msg); raise Exception.Create(e_Math_InvalidArgument, Msg);
end; end;
{$ENDIF}
function DegToRad(Degrees: Extended): Extended; { Radians := Degrees * PI / 180 } function DegToRad(Degrees: Extended): Extended; { Radians := Degrees * PI / 180 }
begin begin
@ -940,6 +941,15 @@ begin
Result := Data[I]; Result := Data[I];
end; end;
{$IFDEF ASM_VERSION}
function Min(A,B: Integer): Integer;
asm
CMP EAX, EDX
JL @@1
XCHG EAX, EDX
@@1:
end;
{$ELSE}
function Min(A,B: Integer): Integer; function Min(A,B: Integer): Integer;
begin begin
if A < B then if A < B then
@ -947,6 +957,7 @@ begin
else else
Result := B; Result := B;
end; end;
{$ENDIF}
{$IFDEF _D4orHigher} {$IFDEF _D4orHigher}
function Min(A,B: I64): I64; function Min(A,B: I64): I64;
@ -1010,6 +1021,15 @@ begin
Result := Data[I]; Result := Data[I];
end; end;
{$IFDEF ASM_VERSION}
function Max(A,B: Integer): Integer;
asm
CMP EAX, EDX
JG @@1
XCHG EAX, EDX
@@1:
end;
{$ELSE}
function Max(A,B: Integer): Integer; function Max(A,B: Integer): Integer;
begin begin
if A > B then if A > B then
@ -1017,6 +1037,7 @@ begin
else else
Result := B; Result := B;
end; end;
{$ENDIF}
{$IFDEF _D4orHigher} {$IFDEF _D4orHigher}
function Max(A,B: I64): I64; function Max(A,B: I64): I64;
@ -1161,24 +1182,31 @@ asm // IN: EAX = ptr to Data, EDX = High(Data) = Count - 1
DD @@4 DD @@4
@@4: @@4:
ADD EAX, [ECX+12+EDX] ADD EAX, [ECX+12+EDX]
JO RaiseOverflowError JO @@RaiseOverflowError
@@3: @@3:
ADD EAX, [ECX+8+EDX] ADD EAX, [ECX+8+EDX]
JO RaiseOverflowError JO @@RaiseOverflowError
@@2: @@2:
ADD EAX, [ECX+4+EDX] ADD EAX, [ECX+4+EDX]
JO RaiseOverflowError JO @@RaiseOverflowError
@@1: @@1:
ADD EAX, [ECX+EDX] ADD EAX, [ECX+EDX]
JO RaiseOverflowError JO @@RaiseOverflowError
SUB EDX,16 SUB EDX,16
JNS @@4 JNS @@4
POP EBX POP EBX
RET
@@RaiseOverflowError:
POP EBX
POP ECX
JMP RaiseOverflowError
end; end;
procedure RaiseOverflowError; procedure RaiseOverflowError;
begin begin
{$IFNDEF MATH_NOERR}
raise Exception.Create(e_IntOverflow, SIntOverflow); raise Exception.Create(e_IntOverflow, SIntOverflow);
{$ENDIF}
end; end;
function SUM(const Data: array of Double): Extended; function SUM(const Data: array of Double): Extended;
@ -1353,7 +1381,9 @@ end;
function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended; function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended;
{ Spreads depreciation linearly over life. } { Spreads depreciation linearly over life. }
begin begin
{$IFNDEF MATH_NOERR}
if Life < 1 then ArgError('SLNDepreciation'); if Life < 1 then ArgError('SLNDepreciation');
{$ENDIF}
Result := (Cost - Salvage) / Life Result := (Cost - Salvage) / Life
end; end;
@ -1425,17 +1455,23 @@ var
begin begin
InternalRateOfReturn := 0; InternalRateOfReturn := 0;
K := ConditionP(CashFlows); K := ConditionP(CashFlows);
{$IFNDEF MATH_NOERR}
if K < 0 then ArgError('InternalRateOfReturn'); if K < 0 then ArgError('InternalRateOfReturn');
{$ENDIF}
if K = 0 then if K = 0 then
begin begin
{$IFNDEF MATH_NOERR}
if Guess <= -1.0 then ArgError('InternalRateOfReturn'); if Guess <= -1.0 then ArgError('InternalRateOfReturn');
{$ENDIF}
T := -LnXP1(Guess) T := -LnXP1(Guess)
end else end else
T := 0.0; T := 0.0;
for Count := 1 to MaxIterations do for Count := 1 to MaxIterations do
begin begin
PolyX(CashFlows, Exp(T), Poly); PolyX(CashFlows, Exp(T), Poly);
{$IFNDEF MATH_NOERR}
if Poly.Pos <= Poly.Neg then ArgError('InternalRateOfReturn'); if Poly.Pos <= Poly.Neg then ArgError('InternalRateOfReturn');
{$ENDIF}
if (Poly.Neg >= 0.0) or (Poly.Pos <= 0.0) then if (Poly.Neg >= 0.0) or (Poly.Pos <= 0.0) then
begin begin
InternalRateOfReturn := -1.0; InternalRateOfReturn := -1.0;
@ -1450,7 +1486,9 @@ begin
Exit; Exit;
end end
end; end;
{$IFNDEF MATH_NOERR}
ArgError('InternalRateOfReturn'); ArgError('InternalRateOfReturn');
{$ENDIF}
end; end;
function NetPresentValue(Rate: Extended; const CashFlows: array of Double; function NetPresentValue(Rate: Extended; const CashFlows: array of Double;
@ -1461,7 +1499,9 @@ var
rr: Extended; rr: Extended;
I: Integer; I: Integer;
begin begin
{$IFNDEF MATH_NOERR}
if Rate <= -1.0 then ArgError('NetPresentValue'); if Rate <= -1.0 then ArgError('NetPresentValue');
{$ENDIF}
rr := 1/(1+Rate); rr := 1/(1+Rate);
result := 0; result := 0;
for I := High(CashFlows) downto Low(CashFlows) do for I := High(CashFlows) downto Low(CashFlows) do
@ -1510,7 +1550,9 @@ var
Arn:extended; { =AnnuityF(Rate,NPeriods) } Arn:extended; { =AnnuityF(Rate,NPeriods) }
begin begin
{$IFNDEF MATH_NOERR}
if Rate <= -1.0 then ArgError('PaymentParts'); if Rate <= -1.0 then ArgError('PaymentParts');
{$ENDIF}
Crp:=Compound(Rate,Period-1); Crp:=Compound(Rate,Period-1);
Arn:=Annuity2(Rate,NPeriods,PaymentTime,Crn); Arn:=Annuity2(Rate,NPeriods,PaymentTime,Crn);
IntPmt:=(FutureValue*(Crp-1)-PresentValue*(Crn-Crp))/Arn; IntPmt:=(FutureValue*(Crp-1)-PresentValue*(Crn-Crp))/Arn;
@ -1522,9 +1564,13 @@ function FutureValue(Rate: Extended; NPeriods: Integer; Payment, PresentValue:
var var
Annuity, CompoundRN: Extended; Annuity, CompoundRN: Extended;
begin begin
{$IFNDEF MATH_NOERR}
if Rate <= -1.0 then ArgError('FutureValue'); if Rate <= -1.0 then ArgError('FutureValue');
{$ENDIF}
Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN); Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN);
{$IFNDEF MATH_NOERR}
if CompoundRN > 1.0E16 then ArgError('FutureValue'); if CompoundRN > 1.0E16 then ArgError('FutureValue');
{$ENDIF}
FutureValue := -Payment * Annuity - PresentValue * CompoundRN FutureValue := -Payment * Annuity - PresentValue * CompoundRN
end; end;
@ -1535,11 +1581,13 @@ var
Crn:extended; { compound(rate,nperiods)} Crn:extended; { compound(rate,nperiods)}
Arn:extended; { annuityf(rate,nperiods)} Arn:extended; { annuityf(rate,nperiods)}
begin begin
{$IFNDEF MATH_NOERR}
if (Rate <= -1.0) if (Rate <= -1.0)
or (Period < 1) or (Period > NPeriods) then ArgError('InterestPayment'); or (Period < 1) or (Period > NPeriods) then ArgError('InterestPayment');
Crp:=Compound(Rate,Period-1); {$ENDIF}
Arn:=Annuity2(Rate,Nperiods,PaymentTime,Crn); Crp:=Compound(Rate,Period-1);
InterestPayment:=(FutureValue*(Crp-1)-PresentValue*(Crn-Crp))/Arn; Arn:=Annuity2(Rate,Nperiods,PaymentTime,Crn);
InterestPayment:=(FutureValue*(Crp-1)-PresentValue*(Crn-Crp))/Arn;
end; end;
function InterestRate(NPeriods: Integer; function InterestRate(NPeriods: Integer;
@ -1577,7 +1625,9 @@ var
begin begin
Result := 0; Result := 0;
{$IFNDEF MATH_NOERR}
if NPeriods <= 0 then ArgError('InterestRate'); if NPeriods <= 0 then ArgError('InterestRate');
{$ENDIF}
Pmt := Payment; Pmt := Payment;
if PaymentTime = ptEndOfPeriod then if PaymentTime = ptEndOfPeriod then
begin begin
@ -1605,7 +1655,9 @@ begin
Pmt := -Pmt; Pmt := -Pmt;
Last := -Last Last := -Last
end; end;
{$IFNDEF MATH_NOERR}
if (First = 0.0) or (Last < 0.0) then ArgError('InterestRate'); if (First = 0.0) or (Last < 0.0) then ArgError('InterestRate');
{$ENDIF}
T := 0.0; { Guess at solution } T := 0.0; { Guess at solution }
for Count := 1 to MaxIterations do for Count := 1 to MaxIterations do
begin begin
@ -1639,7 +1691,9 @@ begin
Exit; Exit;
end end
end; end;
{$IFNDEF MATH_NOERR}
ArgError('InterestRate'); ArgError('InterestRate');
{$ENDIF}
end; end;
function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended; function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended;
@ -1654,8 +1708,9 @@ var
T: Extended; T: Extended;
begin begin
{$IFNDEF MATH_NOERR}
if Rate <= -1.0 then ArgError('NumberOfPeriods'); if Rate <= -1.0 then ArgError('NumberOfPeriods');
{$ENDIF}
{whenever both Payment and PaymentTime are given together, the PaymentTime has the effect {whenever both Payment and PaymentTime are given together, the PaymentTime has the effect
of modifying the effective Payment by the interest accrued on the Payment} of modifying the effective Payment by the interest accrued on the Payment}
@ -1672,7 +1727,9 @@ begin
be numerically unstable, but not as likely to cause an error.} be numerically unstable, but not as likely to cause an error.}
PVRPP:=PresentValue*Rate+Payment; PVRPP:=PresentValue*Rate+Payment;
{$IFNDEF MATH_NOERR}
if PVRPP=0 then ArgError('NumberOfPeriods'); if PVRPP=0 then ArgError('NumberOfPeriods');
{$ENDIF}
{ 6.1E-5 approx= 2**-14 } { 6.1E-5 approx= 2**-14 }
if ( EAbs(Rate)<6.1E-5 ) then if ( EAbs(Rate)<6.1E-5 ) then
@ -1686,7 +1743,9 @@ begin
reasonableness of the cashflow before computing the NPER.} reasonableness of the cashflow before computing the NPER.}
T:= -(PresentValue+FutureValue)*Rate/PVRPP; T:= -(PresentValue+FutureValue)*Rate/PVRPP;
{$IFNDEF MATH_NOERR}
if T<=-1.0 then ArgError('NumberOfPeriods'); if T<=-1.0 then ArgError('NumberOfPeriods');
{$ENDIF}
Result := LnXP1(T) / LnXP1(Rate) Result := LnXP1(T) / LnXP1(Rate)
end; end;
NumberOfPeriods:=Result; NumberOfPeriods:=Result;
@ -1697,7 +1756,9 @@ function Payment(Rate: Extended; NPeriods: Integer; PresentValue, FutureValue:
var var
Annuity, CompoundRN: Extended; Annuity, CompoundRN: Extended;
begin begin
{$IFNDEF MATH_NOERR}
if Rate <= -1.0 then ArgError('Payment'); if Rate <= -1.0 then ArgError('Payment');
{$ENDIF}
Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN); Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN);
if CompoundRN > 1.0E16 then if CompoundRN > 1.0E16 then
Payment := -PresentValue * Rate / (1 + Integer(PaymentTime) * Rate) Payment := -PresentValue * Rate / (1 + Integer(PaymentTime) * Rate)
@ -1710,7 +1771,9 @@ function PeriodPayment(Rate: Extended; Period, NPeriods: Integer;
var var
Junk: Extended; Junk: Extended;
begin begin
{$IFNDEF MATH_NOERR}
if (Rate <= -1.0) or (Period < 1) or (Period > NPeriods) then ArgError('PeriodPayment'); if (Rate <= -1.0) or (Period < 1) or (Period > NPeriods) then ArgError('PeriodPayment');
{$ENDIF}
PeriodPayment := PaymentParts(Period, NPeriods, Rate, PresentValue, PeriodPayment := PaymentParts(Period, NPeriods, Rate, PresentValue,
FutureValue, PaymentTime, Junk); FutureValue, PaymentTime, Junk);
end; end;
@ -1720,7 +1783,9 @@ function PresentValue(Rate: Extended; NPeriods: Integer; Payment, FutureValue:
var var
Annuity, CompoundRN: Extended; Annuity, CompoundRN: Extended;
begin begin
{$IFNDEF MATH_NOERR}
if Rate <= -1.0 then ArgError('PresentValue'); if Rate <= -1.0 then ArgError('PresentValue');
{$ENDIF}
Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN); Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN);
if CompoundRN > 1.0E16 then if CompoundRN > 1.0E16 then
PresentValue := -(Payment / Rate * Integer(PaymentTime) * Payment) PresentValue := -(Payment / Rate * Integer(PaymentTime) * Payment)

77
Addons/err.pas
View File

@ -21,11 +21,10 @@
Key Objects Library (C) 2000 by Kladov Vladimir. Key Objects Library (C) 2000 by Kladov Vladimir.
mailto: bonanzas@xcl.cjb.net mailto: vk@kolmck.net
Home: http://kol.nm.ru Home: http://kolmck.net
http://xcl.cjb.net
http://xcl.nm.ru
This version is compatible with KOL 3.00+
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}
{ {
This code is grabbed mainly from standard SysUtils.pas unit, This code is grabbed mainly from standard SysUtils.pas unit,
@ -125,7 +124,7 @@ resourcestring
SReadAccess = 'Read'; SReadAccess = 'Read';
SWriteAccess = 'Write'; SWriteAccess = 'Write';
//SResultTooLong = 'Format result longer than 4096 characters'; //SResultTooLong = 'Format result longer than 4096 characters';
//SFormatTooLong = 'Format AnsiString too long'; //SFormatTooLong = 'Format string too long';
SExternalException = 'External exception %x'; SExternalException = 'External exception %x';
SAssertionFailed = 'Assertion failed'; SAssertionFailed = 'Assertion failed';
SIntfCastError = 'Interface not supported'; SIntfCastError = 'Interface not supported';
@ -152,7 +151,7 @@ type
{ Generic filename type } { Generic filename type }
TFileName = type AnsiString; TFileName = type string;
{ Exceptions } { Exceptions }
Exception = class; Exception = class;
@ -177,31 +176,31 @@ type
protected protected
FCode: TError; FCode: TError;
FErrorCode: DWORD; FErrorCode: DWORD;
FMessage: AnsiString; FMessage: KOLString;
FExceptionRecord: PExceptionRecord; FExceptionRecord: PExceptionRecord;
FData: Pointer; FData: Pointer;
FOnDestroy: TDestroyException; FOnDestroy: TDestroyException;
procedure SetData(const Value: Pointer); procedure SetData(const Value: Pointer);
public public
constructor Create(ACode: TError; const Msg: AnsiString); constructor Create(ACode: TError; const Msg: string);
{* Use this constructor to raise exception, which does not require of {* Use this constructor to raise exception, which does not require of
argument formatting. } argument formatting. }
constructor CreateFmt(ACode: TError; const Msg: AnsiString; const Args: array of const); constructor CreateFmt(ACode: TError; const Msg: string; const Args: array of const);
{* Use this constructor to raise an exception with formatted Message AnsiString. {* Use this constructor to raise an exception with formatted Message string.
Take into attention, that Format procedure defined in KOL, uses API wvsprintf Take into attention, that Format procedure defined in KOL, uses API wvsprintf
function, which can understand a restricted set of format specifications. } function, which can understand a restricted set of format specifications. }
constructor CreateCustom(AError: DWORD; const Msg: AnsiString); constructor CreateCustom(AError: DWORD; const Msg: String);
{* Use this constructor to create e_Custom exception and to assign AError to {* Use this constructor to create e_Custom exception and to assign AError to
its ErrorCode property. } its ErrorCode property. }
constructor CreateCustomFmt(AError: DWORD; const Msg: AnsiString; const Args: array of const); constructor CreateCustomFmt(AError: DWORD; const Msg: String; const Args: array of const);
{* Use this constructor to create e_Custom exception with formatted message {* Use this constructor to create e_Custom exception with formatted message
AnsiString and to assign AError to its ErrorCode property. } string and to assign AError to its ErrorCode property. }
constructor CreateResFmt(ACode: TError; Ident: Integer; const Args: array of const); constructor CreateResFmt(ACode: TError; Ident: Integer; const Args: array of const);
{* } {* }
destructor Destroy; override; destructor Destroy; override;
{* destructor } {* destructor }
property Message: AnsiString read FMessage; // write FMessage; property Message: KOLString read FMessage; // write FMessage;
{* Text AnsiString, containing descriptive message about the exception. } {* Text string, containing descriptive message about the exception. }
property Code: TError read FCode; property Code: TError read FCode;
{* Main exception code. This property can be used to determine, which exception {* Main exception code. This property can be used to determine, which exception
occure. } occure. }
@ -253,7 +252,7 @@ procedure AddExitProc(Proc: TProcedure);
{ System error messages } { System error messages }
function SysErrorMessage(ErrorCode: Integer): AnsiString; function SysErrorMessage(ErrorCode: Integer): string;
{ Exception handling routines } { Exception handling routines }
@ -327,7 +326,7 @@ function SafeLoadLibrary(const Filename: KOLString;
implementation implementation
{procedure ConvertError(const Ident: AnsiString); {procedure ConvertError(const Ident: string);
begin begin
raise Exception.Create(e_Convert, Ident); raise Exception.Create(e_Convert, Ident);
end; end;
@ -385,7 +384,7 @@ end;
{ System error messages } { System error messages }
function SysErrorMessage(ErrorCode: Integer): AnsiString; function SysErrorMessage(ErrorCode: Integer): string;
var var
Len: Integer; Len: Integer;
Buffer: array[0..255] of KOLChar; Buffer: array[0..255] of KOLChar;
@ -492,7 +491,7 @@ end;
{$ENDIF} {$ENDIF}
{$IFDEF _D2} {$IFDEF _D2}
function LoadStr(Ident: Integer): AnsiString; function LoadStr(Ident: Integer): string;
var var
Buffer: array[0..1023] of Char; Buffer: array[0..1023] of Char;
begin begin
@ -500,7 +499,7 @@ begin
SizeOf(Buffer))); SizeOf(Buffer)));
end; end;
{$ELSE} {$ELSE}
function LoadStr(Ident: Integer): AnsiString; function LoadStr(Ident: Integer): string;
var var
Buffer: array[0..1023] of KOLChar; Buffer: array[0..1023] of KOLChar;
begin begin
@ -508,7 +507,7 @@ begin
end; end;
{$ENDIF} {$ENDIF}
function FmtLoadStr(Ident: Integer; const Args: array of const): AnsiString; function FmtLoadStr(Ident: Integer; const Args: array of const): string;
begin begin
//FmtStr(Result, LoadStr(Ident), Args); //FmtStr(Result, LoadStr(Ident), Args);
Result := Format(LoadStr(Ident), Args); Result := Format(LoadStr(Ident), Args);
@ -517,12 +516,12 @@ end;
function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
Buffer: PKOLChar; Size: Integer): Integer; Buffer: PKOLChar; Size: Integer): Integer;
var var
MsgPtr: PAnsiChar; MsgPtr: PKOLChar;
//MsgEnd: PAnsiChar; //MsgEnd: PChar;
//MsgLen: Integer; //MsgLen: Integer;
ModuleName: array[0..MAX_PATH] of KOLChar; ModuleName: array[0..MAX_PATH] of KOLChar;
//Temp: array[0..MAX_PATH] of Char; //Temp: array[0..MAX_PATH] of Char;
Fmt: array[0..255] of AnsiChar; Fmt: array[0..255] of KOLChar;
Info: TMemoryBasicInformation; Info: TMemoryBasicInformation;
ConvertedAddress: Pointer; ConvertedAddress: Pointer;
begin begin
@ -543,21 +542,21 @@ begin
//MsgEnd := ''; //MsgEnd := '';
if ExceptObject is Exception then if ExceptObject is Exception then
begin begin
MsgPtr := PAnsiChar(Exception(ExceptObject).Message); MsgPtr := PKOLChar(Exception(ExceptObject).Message);
//MsgLen := StrLen(MsgPtr); //MsgLen := StrLen(MsgPtr);
//if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.'; //if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.';
{-} // Isn't it too beautiful - devote ~40 bytes of code just to decide, {-} // Isn't it too beautiful - devote ~40 bytes of code just to decide,
// add or not a point at the end of the message. // add or not a point at the end of the message.
end; end;
{$IFNDEF USE_RESOURCESTRING} {$IFNDEF USE_RESOURCESTRING}
StrCopy( Fmt, SException ); {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}( Fmt, SException );
{$ELSE} {$ELSE}
LoadString(FindResourceHInstance(HInstance), LoadString(FindResourceHInstance(HInstance),
PResStringRec(@SException).Identifier, Fmt, SizeOf(Fmt)); PResStringRec(@SException).Identifier, Fmt, SizeOf(Fmt));
{$ENDIF} {$ENDIF}
//MsgOK( ModuleName ); //MsgOK( ModuleName );
{$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF} {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
( Buffer, PKOLChar( Format( KOLString(Fmt), [ ExceptObject.ClassName, ( Buffer, PKOLChar( Format( Fmt, [ ExceptObject.ClassName,
ModuleName, ConvertedAddress, MsgPtr, '' {MsgEnd}]) ) ); ModuleName, ConvertedAddress, MsgPtr, '' {MsgEnd}]) ) );
Result := {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}(Buffer); Result := {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}(Buffer);
end; end;
@ -620,21 +619,21 @@ begin
FData := Value; FData := Value;
end; end;
constructor Exception.Create(ACode: TError; const Msg: AnsiString); constructor Exception.Create(ACode: TError; const Msg: string);
begin begin
FCode := ACode; FCode := ACode;
FMessage := Msg; FMessage := Msg;
//FAllowFree := TRUE; //FAllowFree := TRUE;
end; end;
constructor Exception.CreateCustom(AError: DWORD; const Msg: AnsiString); constructor Exception.CreateCustom(AError: DWORD; const Msg: String);
begin begin
FCode := e_Custom; FCode := e_Custom;
FMessage := Msg; FMessage := Msg;
FErrorCode := AError; FErrorCode := AError;
end; end;
constructor Exception.CreateCustomFmt(AError: DWORD; const Msg: AnsiString; constructor Exception.CreateCustomFmt(AError: DWORD; const Msg: String;
const Args: array of const); const Args: array of const);
begin begin
FCode := e_Custom; FCode := e_Custom;
@ -642,7 +641,7 @@ begin
FMessage := Format(Msg, Args); FMessage := Format(Msg, Args);
end; end;
constructor Exception.CreateFmt(ACode: TError; const Msg: AnsiString; constructor Exception.CreateFmt(ACode: TError; const Msg: string;
const Args: array of const); const Args: array of const);
begin begin
FCode := ACode; FCode := ACode;
@ -663,7 +662,7 @@ function CreateInOutError: Exception;
type type
TErrorRec = record TErrorRec = record
Code: Integer; Code: Integer;
Ident: AnsiString; Ident: string;
end; end;
const const
ErrorMap: array[0..5] of TErrorRec = ( ErrorMap: array[0..5] of TErrorRec = (
@ -694,7 +693,7 @@ end;
type type
TExceptMapRec = packed record TExceptMapRec = packed record
ECode: TError; ECode: TError;
EIdent: AnsiString; EIdent: String;
end; end;
const const
@ -765,10 +764,10 @@ end;
{ routine RaiseAssertException sets up the registers just as if the user } { routine RaiseAssertException sets up the registers just as if the user }
{ code itself had raised the exception. } { code itself had raised the exception. }
function CreateAssertException(const Message, Filename: AnsiString; function CreateAssertException(const Message, Filename: string;
LineNumber: Integer): Exception; LineNumber: Integer): Exception;
var var
S: AnsiString; S: string;
begin begin
if Message <> '' then S := Message else S := SAssertionFailed; if Message <> '' then S := Message else S := SAssertionFailed;
Result := Exception.CreateFmt(e_Assertion, SAssertError, Result := Exception.CreateFmt(e_Assertion, SAssertError,
@ -790,13 +789,13 @@ end;
{ If you change this procedure, make sure it does not have any local variables } { If you change this procedure, make sure it does not have any local variables }
{ or temps that need cleanup - they won't get cleaned up due to the way } { or temps that need cleanup - they won't get cleaned up due to the way }
{ RaiseAssertException frame works. Also, it can not have an exception frame. } { RaiseAssertException frame works. Also, it can not have an exception frame. }
procedure AssertErrorHandler(const Message, Filename: AnsiString; procedure AssertErrorHandler(const Message, Filename: string;
LineNumber: Integer; ErrorAddr: Pointer); LineNumber: Integer; ErrorAddr: Pointer);
var var
E: Exception; E: Exception;
begin begin
E := CreateAssertException(Message, Filename, LineNumber); E := CreateAssertException(Message, Filename, LineNumber);
RaiseAssertException(E, ErrorAddr, PAnsiChar(@ErrorAddr)+4); RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+4);
end; end;
{ Abstract method invoke error handler } { Abstract method invoke error handler }
@ -891,7 +890,7 @@ var
function CreateAVObject: Exception; function CreateAVObject: Exception;
var var
AccessOp: AnsiString; // AnsiString ID indicating the access type READ or WRITE AccessOp: string; // string ID indicating the access type READ or WRITE
AccessAddress: Pointer; AccessAddress: Pointer;
MemInfo: TMemoryBasicInformation; MemInfo: TMemoryBasicInformation;
ModName: array[0..MAX_PATH] of KOLChar; ModName: array[0..MAX_PATH] of KOLChar;
@ -933,7 +932,7 @@ end;
procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); far; procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); far;
begin begin
ShowException(ExceptObject, ExceptAddr); ShowException(ExceptObject, ExceptAddr);
Halt(1); Halt(1);
end; end;
{+} {+}

946
KOL.pas
View File

File diff suppressed because it is too large Load Diff

9
KOLDEF.inc
View File

@ -218,9 +218,9 @@ That is all to have full compatibility.
// directive there. (Search the word: USE_CUSTOMEXTENSIONS). // directive there. (Search the word: USE_CUSTOMEXTENSIONS).
// Please note, that this option is not fully supported now. // Please note, that this option is not fully supported now.
{$IFNDEF NOT_UNLOAD_RICHEDITLIB} //{$IFNDEF NOT_UNLOAD_RICHEDITLIB}
{$DEFINE UNLOAD_RICHEDITLIB} // {$DEFINE UNLOAD_RICHEDITLIB}
{$ENDIF} //{$ENDIF}
// You can freely comment this directive. 1st, if the application does not // You can freely comment this directive. 1st, if the application does not
// use richedit control. 2nd, even if it does, freeing the library handle // use richedit control. 2nd, even if it does, freeing the library handle
// actually is not needed. // actually is not needed.
@ -248,5 +248,4 @@ That is all to have full compatibility.
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
{$DEFINE DIBPixels32bitWithAlpha}

612
KOL_ASM.inc
View File

@ -2178,63 +2178,6 @@ asm
POP EBX POP EBX
end; end;
function TCanvas.TextExtent(const Text: AnsiString): TSize;
asm
PUSH EBX
PUSH ESI
MOV EBX, EAX
PUSH ECX // prepare @Result
MOV EAX, EDX
CALL System.@LStrLen
PUSH EAX // prepare Length(Text)
CALL EDX2PChar
PUSH EDX // prepare PChar(Text)
PUSH HandleValid or FontValid
PUSH EBX
CALL RequiredState
XCHG ESI, EAX
TEST ESI, ESI // ESI = fHandle before
JNZ @@1
PUSH ESI
CALL CreateCompatibleDC
MOV EDX, EBX
XCHG EAX, EDX // EAX := @Self; EDX := DC
CALL SetHandle
//****************************************************** // Added By M.Gerasimov
CMP [EBX].TCanvas.fIsPaintDC, 1
JZ @@2
XOR ESI,ESI
@@2:
//******************************************************
@@1:
PUSH HandleValid or FontValid
PUSH EBX
CALL RequiredState
PUSH EAX // prepare DC
CALL Windows.GetTextExtentPoint32A // KOL_ANSI
TEST ESI, ESI
JNZ @@exit
XOR EDX, EDX
XCHG EAX, EBX
CALL SetHandle
@@exit:
POP ESI
POP EBX
end;
procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: Ansistring); procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: Ansistring);
asm asm
PUSH EBX PUSH EBX
@ -2795,8 +2738,8 @@ asm //cmd //opd
CALL System.@GetMem CALL System.@GetMem
POP EDX POP EDX
PUSH EAX PUSH EAX
MOV CL, 0 //MOV CL, 0
CALL System.@FillChar CALL ZeroMemory
POP EAX POP EAX
@@exit: @@exit:
end; end;
@ -3346,189 +3289,6 @@ asm
POP EAX POP EAX
end; end;
function _NewTControl( AParent: PControl ): PControl;
begin
New( Result, CreateParented( AParent ) );
end;
function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar;
Ctl3D: Boolean; ACommandActions: TCommandActionsParam ): PControl;
asm
PUSH EBX
PUSH ESI
PUSH EDI
MOV EDI, [ACommandActions]
MOV [ACommandActions], ECX // Ctl3D -> ACommandActions
PUSH EDX // ControlClassName
MOV ESI, EAX // ESI = AParent
CALL _NewTControl
XCHG EBX, EAX // EBX = Result
POP [EBX].TControl.fControlClassName
//INC [EBX].TControl.fWindowed // set in TControl.Init
{$IFDEF COMMANDACTIONS_OBJ}
MOV EAX, EDI
CMP EAX, 120
JB @@IdxActions_Loaded
MOVZX EAX, byte ptr[EDI]
@@IdxActions_Loaded:
PUSH EAX
MOV ECX, dword ptr [AllActions_Objs + EAX*4]
JECXZ @@create_new_action
XCHG EAX, ECX
PUSH EAX
CALL TObj.RefInc
POP EAX
JMP @@action_assign
@@create_new_action:
{$IFDEF PACK_COMMANDACTIONS}
MOV EAX, EDI
CALL NewCommandActionsObj_Packed
{$ELSE not PACK_COMMANDACTIONS}
CALL NewCommandActionsObj
TEST EDI, EDI
JZ @@no_actions
PUSH EAX
LEA EDX, [EAX].TCommandActionsObj.aClear
XCHG EAX, EDI
XOR ECX, ECX
MOV CL, Byte(Sizeof(TCommandActions))
CALL Move
POP EAX
JMP @@action_assign
@@no_actions:
{$ENDIF not PACK_COMMANDACTIONS}
MOV [EAX].TCommandActionsObj.aClear, offset[ClearText]
@@action_assign:
POP EDX
MOV dword ptr [AllActions_Objs + EDX*4], EAX
MOV [EBX].TControl.fCommandActions, EAX
XCHG EDX, EAX
MOV EAX, EBX
CALL TControl.Add2AutoFree
{$ELSE}
TEST EDI, EDI
JZ @@no_actions2
LEA EDX, [EBX].TControl.fCommandActions
XCHG EAX, EDI
XOR ECX, ECX
MOV CL, Byte(Sizeof(TCommandActions))
CALL Move
JMP @@actions_created
@@no_actions2:
MOV [EBX].TControl.fCommandActions.TCommandActions.aClear, offset[ClearText]
{$ENDIF}
@@actions_created:
TEST ESI, ESI
JZ @@no_parent
(*
PUSH ESI
LEA ESI, [ESI].TControl.PP.fWndProcResizeFlicks
LEA EDI, [EBX].TControl.PP.fWndProcResizeFlicks
MOVSD // fWndProcResizeFlicks
MOVSD // fGotoControl
POP ESI
*)
LEA ESI, [ESI].TControl.fTextColor
LEA EDI, [EBX].TControl.fTextColor
MOVSD // fTextColor
MOVSD // fColor
{$IFDEF SMALLEST_CODE}
{$IFDEF SMALLEST_CODE_PARENTFONT}
LODSD
XCHG EDX, EAX
XOR EAX, EAX
CALL TGraphicTool.Assign
STOSD // fFont
{$ELSE}
LODSD
XOR EAX, EAX
STOSD // fFont = nil
{$ENDIF}
{$ELSE}
LODSD
XCHG EDX, EAX
XOR EAX, EAX
PUSH EDX
CALL TGraphicTool.Assign
STOSD // fFont
POP EDX
XCHG ECX, EAX
JECXZ @@no_font
MOV [ECX].TGraphicTool.fParentGDITool, EDX
MOV [ECX].TGraphicTool.fOnChange.TMethod.Code, offset[TControl.FontChanged]
MOV [ECX].TGraphicTool.fOnChange.TMethod.Data, EBX
MOV EAX, EBX
MOV EDX, ECX
CALL TControl.FontChanged
{$IFDEF USE_AUTOFREE4CONTROLS}
MOV EAX, EBX
MOV EDX, [EBX].TControl.fFont
CALL TControl.Add2AutoFree
{$ENDIF}
@@no_font:
{$ENDIF}
{$IFDEF SMALLEST_CODE}
LODSD
XOR EAX, EAX
STOSD
{$ELSE}
LODSD
XCHG EDX, EAX
XOR EAX, EAX
PUSH EDX
CALL TGraphicTool.Assign
STOSD // fBrush
POP EDX
XCHG ECX, EAX
JECXZ @@no_brush
MOV [ECX].TGraphicTool.fParentGDITool, EDX
MOV [ECX].TGraphicTool.fOnChange.TMethod.Code, offset[TControl.BrushChanged]
MOV [ECX].TGraphicTool.fOnChange.TMethod.Data, EBX
MOV EAX, EBX
MOV EDX, ECX
CALL TControl.BrushChanged
{$IFDEF USE_AUTOFREE4CONTROLS}
MOV EAX, EBX
MOV EDX, [EBX].TControl.fBrush
CALL TControl.Add2AutoFree
{$ENDIF}
@@no_brush:
{$ENDIF}
MOVSB // fMargin
LODSD // skip fClientXXXXX
ADD EDI, 4
LODSB // fCtl3D_child
TEST AL, 2
JZ @@passed3D
MOV EDX, [ACommandActions] // DL <- Ctl3D !!!
AND AL, not 1
AND DL, 1
OR EAX, EDX
@@passed3D:
STOSB // fCtl3D_child
@@no_parent:
XCHG EAX, EBX
POP EDI
POP ESI
POP EBX
end;
function NewForm( AParent: PControl; const Caption: KOLString ): PControl; function NewForm( AParent: PControl; const Caption: KOLString ): PControl;
const FormClass: array[ 0..4 ] of KOLChar = ( 'F', 'o', 'r', 'm', #0 ); const FormClass: array[ 0..4 ] of KOLChar = ( 'F', 'o', 'r', 'm', #0 );
asm asm
@ -9915,6 +9675,30 @@ procedure TStrList.Sort(CaseSensitive: Boolean);
asm asm
MOV [EAX].fCaseSensitiveSort, DL MOV [EAX].fCaseSensitiveSort, DL
MOV [EAX].fAnsiSort, 0 MOV [EAX].fAnsiSort, 0
{$IFDEF SPEED_FASTER}
{$DEFINE SORT_STRLIST_ARRAY}
{$ENDIF}
{$IFDEF TLIST_FAST}
{$UNDEF SORT_STRLIST_ARRAY}
{$ENDIF}
{$IFDEF SORT_STRLIST_ARRAY}
MOV ECX, offset[StrComp]
CMP DL, 0
JNZ @@01
{$IFDEF SMALLER_CODE}
MOV ECX, offset[StrComp_NoCase]
{$ELSE}
MOV ECX, [StrComp_NoCase]
{$ENDIF}
@@01:
MOV EAX, [EAX].fList
MOV EDX, [EAX].TList.fCount
CMP EDX, 1
JLE @@02
MOV EAX, [EAX].TList.fItems
CALL SortArray
@@02:
{$ELSE}
PUSH Offset[TStrList.Swap] PUSH Offset[TStrList.Swap]
MOV ECX, Offset[CompareStrListItems_Case] MOV ECX, Offset[CompareStrListItems_Case]
CMP DL, 0 CMP DL, 0
@ -9922,19 +9706,7 @@ asm
MOV ECX, Offset[CompareStrListItems_NoCase] MOV ECX, Offset[CompareStrListItems_NoCase]
@1: MOV EDX, [EAX].fCount @1: MOV EDX, [EAX].fCount
CALL SortData CALL SortData
end; {$ENDIF}
procedure TStrList.AnsiSort(CaseSensitive: Boolean);
asm
MOV [EAX].fCaseSensitiveSort, DL
MOV [EAX].fAnsiSort, 1
PUSH Offset[TStrList.Swap]
MOV ECX, Offset[CompareAnsiStrListItems]
CMP DL, 0
JZ @1
MOV ECX, Offset[CompareAnsiStrListItems_Case]
@1: MOV EDX, [EAX].fCount
CALL SortData
end; end;
procedure TStrList.MergeFromFile(const FileName: KOLString); procedure TStrList.MergeFromFile(const FileName: KOLString);
@ -10166,6 +9938,326 @@ asm
end; end;
procedure SortArray( const Data: Pointer; const uNElem: Dword;
const CompareFun: TCompareArrayEvent );
asm
PUSH EBP
MOV EBP, ESP
CMP EDX, 2
JL @@exit
SUB EAX, 4
PUSH EAX // [EBP-4] = Data
PUSH ECX // [EBP-8] = CompareFun
PUSH EBX // EBX = pivotP
XOR EBX, EBX
INC EBX // EBX = 1 to pass to qSortHelp as PivotP
MOV EAX, EDX // EAX = nElem
CALL @@qSortHelp
POP EBX
POP ECX
POP ECX
@@exit:
POP EBP
RET
@@qSortHelp:
PUSH EBX // EBX (in) = PivotP
PUSH ESI // ESI = leftP
PUSH EDI // EDI = rightP
@@TailRecursion:
CMP EAX, 2
JG @@2
JNE @@exit_qSortHelp
LEA ECX, [EBX+1]
MOV EDX, EBX
//CALL @@Compare
PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [EBP-4]
MOV EAX, [EAX + EDX*4]
MOV EDX, [EBP-4]
MOV EDX, [EDX + ECX*4]
CALL dword ptr [EBP-8]
POP ECX
POP EDX
TEST EAX, EAX
POP EAX
JLE @@exit_qSortHelp
@@swp_exit:
//CALL @@Swap
PUSH EAX
PUSH ESI
MOV ESI, [EBP-4]
MOV EAX, [ESI+EDX*4]
XCHG EAX, [ESI+ECX*4]
MOV [ESI+EDX*4], EAX
POP ESI
POP EAX
@@exit_qSortHelp:
POP EDI
POP ESI
POP EBX
RET
// ESI = leftP
// EDI = rightP
@@2: LEA EDI, [EAX+EBX-1]
MOV ESI, EAX
SHR ESI, 1
ADD ESI, EBX
MOV ECX, ESI
MOV EDX, EDI
CALL @@CompareLeSwap
MOV EDX, EBX
//CALL @@Compare
PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [EBP-4]
MOV EAX, [EAX + EDX*4]
MOV EDX, [EBP-4]
MOV EDX, [EDX + ECX*4]
CALL dword ptr [EBP-8]
POP ECX
POP EDX
TEST EAX, EAX
POP EAX
JG @@4
//CALL @@Swap
PUSH EAX
PUSH ESI
MOV ESI, [EBP-4]
MOV EAX, [ESI+EDX*4]
XCHG EAX, [ESI+ECX*4]
MOV [ESI+EDX*4], EAX
POP ESI
POP EAX
JMP @@5
@@4: MOV ECX, EBX
MOV EDX, EDI
CALL @@CompareLeSwap
@@5:
CMP EAX, 3
JNE @@6
MOV EDX, EBX
MOV ECX, ESI
JMP @@swp_exit
@@6: // classic Horae algorithm
PUSH EAX // EAX = pivotEnd
LEA EAX, [EBX+1]
MOV ESI, EAX
@@repeat:
MOV EDX, ESI
MOV ECX, EBX
//CALL @@Compare
PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [EBP-4]
MOV EAX, [EAX + EDX*4]
MOV EDX, [EBP-4]
MOV EDX, [EDX + ECX*4]
CALL dword ptr [EBP-8]
POP ECX
POP EDX
TEST EAX, EAX
POP EAX
JG @@while2
@@while1:
JNE @@7
MOV EDX, ESI
MOV ECX, EAX
//CALL @@Swap
PUSH EAX
PUSH ESI
MOV ESI, [EBP-4]
MOV EAX, [ESI+EDX*4]
XCHG EAX, [ESI+ECX*4]
MOV [ESI+EDX*4], EAX
POP ESI
POP EAX
INC EAX
@@7:
CMP ESI, EDI
JGE @@qBreak
INC ESI
JMP @@repeat
@@while2:
CMP ESI, EDI
JGE @@until
MOV EDX, EBX
MOV ECX, EDI
//CALL @@Compare
PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [EBP-4]
MOV EAX, [EAX + EDX*4]
MOV EDX, [EBP-4]
MOV EDX, [EDX + ECX*4]
CALL dword ptr [EBP-8]
POP ECX
POP EDX
TEST EAX, EAX
POP EAX
JGE @@8
DEC EDI
JMP @@while2
@@8:
MOV EDX, ESI
MOV ECX, EDI
//PUSHFD
//CALL @@Swap
PUSH EAX
PUSH ESI
MOV ESI, [EBP-4]
MOV EAX, [ESI+EDX*4]
XCHG EAX, [ESI+ECX*4]
MOV [ESI+EDX*4], EAX
POP ESI
POP EAX
//POPFD
JE @@until
INC ESI
DEC EDI
@@until:
CMP ESI, EDI
JL @@repeat
@@qBreak:
MOV EDX, ESI
MOV ECX, EBX
//CALL @@Compare
PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [EBP-4]
MOV EAX, [EAX + EDX*4]
MOV EDX, [EBP-4]
MOV EDX, [EDX + ECX*4]
CALL dword ptr [EBP-8]
POP ECX
POP EDX
TEST EAX, EAX
POP EAX
JG @@9
INC ESI
@@9:
PUSH EBX // EBX = PivotTemp
PUSH ESI // ESI = leftTemp
DEC ESI
@@while3:
CMP EBX, EAX
JGE @@while3_break
CMP ESI, EAX
JL @@while3_break
MOV EDX, EBX
MOV ECX, ESI
//CALL @@Swap
PUSH EAX
PUSH ESI
MOV ESI, [EBP-4]
MOV EAX, [ESI+EDX*4]
XCHG EAX, [ESI+ECX*4]
MOV [ESI+EDX*4], EAX
POP ESI
POP EAX
INC EBX
DEC ESI
JMP @@while3
@@while3_break:
POP ESI
POP EBX
MOV EDX, EAX
POP EAX // EAX = nElem
PUSH EDI // EDI = lNum
MOV EDI, ESI
SUB EDI, EDX
ADD EAX, EBX
SUB EAX, ESI
PUSH EBX
PUSH EAX
CMP EAX, EDI
JGE @@10
MOV EBX, ESI
CALL @@qSortHelp
POP EAX
MOV EAX, EDI
POP EBX
JMP @@11
@@10: MOV EAX, EDI
CALL @@qSortHelp
POP EAX
POP EBX
MOV EBX, ESI
@@11:
POP EDI
JMP @@TailRecursion
@@Compare:
PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [EBP-4]
MOV EAX, [EAX + EDX*4]
MOV EDX, [EBP-4]
MOV EDX, [EDX + ECX*4]
CALL dword ptr [EBP-8]
POP ECX
POP EDX
TEST EAX, EAX
POP EAX
RET
@@CompareLeSwap:
//CALL @@Compare
PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [EBP-4]
MOV EAX, [EAX + EDX*4]
MOV EDX, [EBP-4]
MOV EDX, [EDX + ECX*4]
CALL dword ptr [EBP-8]
POP ECX
POP EDX
TEST EAX, EAX
POP EAX
JG @@ret
@@Swap: PUSH EAX
PUSH ESI
MOV ESI, [EBP-4]
MOV EAX, [ESI+EDX*4]
XCHG EAX, [ESI+ECX*4]
MOV [ESI+EDX*4], EAX
POP ESI
//TEST EAX, EAX
POP EAX
@@ret:
RET
end;
function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
asm asm
MOV EDX, [EAX+EDX*4] MOV EDX, [EAX+EDX*4]
@ -13330,7 +13422,11 @@ asm
@@if32bit: @@if32bit:
LOOP @@iffin LOOP @@iffin
INC EDX INC EDX
{$IFDEF DIBPixels32bitWithAlpha}
MOV EAX, offset[_GetDIBPixelsTrueColorAlpha] MOV EAX, offset[_GetDIBPixelsTrueColorAlpha]
{$ELSE}
MOV EAX, offset[_GetDIBPixelsTrueColor]
{$ENDIF}
@@iffin: @@iffin:
MOV byte ptr [EBX].fPixelMask, DH MOV byte ptr [EBX].fPixelMask, DH
MOV byte ptr [EBX].fPixelsPerByteMask, DL MOV byte ptr [EBX].fPixelsPerByteMask, DL
@ -13556,7 +13652,11 @@ asm
@@if32bit: @@if32bit:
LOOP @@ifend LOOP @@ifend
INC EDX INC EDX
MOV EAX, offset[_SetDIBPixelsTrueColorAlpha] {$IFDEF DIBPixels32bitWithAlpha}
MOV EAX, offset[_SetDIBPixelsTrueColor]
{$ELSE}
MOV EAX, offset[_SetDIBPixelsTrueColor]
{$ENDIF}
@@ifend: @@ifend:
MOV byte ptr [EBX].fPixelMask, DH MOV byte ptr [EBX].fPixelMask, DH
MOV byte ptr [EBX].fPixelsPerByteMask, DL MOV byte ptr [EBX].fPixelsPerByteMask, DL

14
visual_xp_styles.inc
View File

@ -498,7 +498,7 @@ begin
else else
RCheck.Top := RCheck.Top + (RCheck.Bottom - RCheck.Top - H) div 2; RCheck.Top := RCheck.Top + (RCheck.Bottom - RCheck.Top - H) div 2;
RCheck.Bottom := RCheck.Top + H; RCheck.Bottom := RCheck.Top + H;
RText := MakeRect(RCheck.Right + Sender.Border, RCheck.Top, RText := MakeRect(RCheck.Right + Sender.fMargin, RCheck.Top,
RClient.Right, RCheck.Bottom); RClient.Right, RCheck.Bottom);
// Getting state // Getting state
fState := 1; {CBS_UNCHECKEDNORMAL} fState := 1; {CBS_UNCHECKEDNORMAL}
@ -561,7 +561,11 @@ begin
DeleteObject(F); DeleteObject(F);
// Draw focusrect // Draw focusrect
if GetFocus = Sender.fHandle then DrawFocusRect(DC, RText); if GetFocus = Sender.fHandle then
begin
dec( RText.Left );
DrawFocusRect(DC, RText);
end;
end; end;
//************************* Drawing RadioBox control *************************// //************************* Drawing RadioBox control *************************//
procedure WndRadioBoxXPDraw( Dummy : Pointer; Sender: PControl; DC: HDC ); procedure WndRadioBoxXPDraw( Dummy : Pointer; Sender: PControl; DC: HDC );
@ -659,7 +663,11 @@ begin
DeleteObject(F); DeleteObject(F);
// Draw focusrect // Draw focusrect
if GetFocus = Sender.fHandle then DrawFocusRect(DC, RText); if GetFocus = Sender.fHandle then
begin
dec( RText.Left );
DrawFocusRect(DC, RText);
end;
end; end;
//******************** Drawing Button and BitButton control ******************// //******************** Drawing Button and BitButton control ******************//