paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-18 07:59:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Trimmed trailing spaces

Browse Source 
git-svn-id: trunk@7663 -
This commit is contained in:
marc 2005-09-10 16:11:44 +00:00
parent 0ae90dd622
commit ac4767765b
1 changed files with 49 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
lcl/widgetset/wslclclasses.pp
View File

@ -1,8 +1,8 @@
{ $Id$} { $Id$}
{ {
***************************************************************************** *****************************************************************************
* wslclclasses.pp * * wslclclasses.pp *
* --------------- * * --------------- *
* * * *
* * * *
***************************************************************************** *****************************************************************************
@ -28,15 +28,15 @@ unit WSLCLClasses;
interface interface
//////////////////////////////////////////////////// ////////////////////////////////////////////////////
// I M P O R T A N T // I M P O R T A N T
//////////////////////////////////////////////////// ////////////////////////////////////////////////////
// 1) Only class methods allowed // 1) Only class methods allowed
// 2) Class methods have to be published and virtual // 2) Class methods have to be published and virtual
// 3) To get as little as possible circles, the uses // 3) To get as little as possible circles, the uses
// clause should contain only those LCL units // clause should contain only those LCL units
// needed for registration. WSxxx units are OK // needed for registration. WSxxx units are OK
// 4) To improve speed, register only classes in the // 4) To improve speed, register only classes in the
// initialization section which actually // initialization section which actually
// implement something // implement something
// 5) To enable your XXX widgetset units, look at // 5) To enable your XXX widgetset units, look at
// the uses clause of the XXXintf.pp // the uses clause of the XXXintf.pp
@ -53,11 +53,11 @@ type
TWSPrivate = class(TObject) TWSPrivate = class(TObject)
end; end;
TWSPrivateClass = class of TWSPrivate; TWSPrivateClass = class of TWSPrivate;
{ TWSLCLComponent } { TWSLCLComponent }
{$M+} {$M+}
TWSLCLComponent = class(TObject) TWSLCLComponent = class(TObject)
protected protected
class function WSPrivate: TWSPrivateClass; //inline; class function WSPrivate: TWSPrivateClass; //inline;
end; end;
@ -118,15 +118,15 @@ begin
while cls <> nil do while cls <> nil do
begin begin
idx := MWSRegisterIndex.IndexOf(cls.ClassName); idx := MWSRegisterIndex.IndexOf(cls.ClassName);
if idx <> -1 if idx <> -1
then begin then begin
Node := PClassNode(MWSRegisterIndex.Objects[idx]); Node := PClassNode(MWSRegisterIndex.Objects[idx]);
Result := TWSLCLComponentClass(Node^.VClass); Result := TWSLCLComponentClass(Node^.VClass);
Exit; Exit;
end; end;
cls := cls.ClassParent; cls := cls.ClassParent;
end; end;
end; end;
type type
TMethodNameTableEntry = packed record TMethodNameTableEntry = packed record
@ -139,29 +139,29 @@ type
Entries: packed array[0..9999999] of TMethodNameTableEntry; Entries: packed array[0..9999999] of TMethodNameTableEntry;
end; end;
PMethodNameTable = ^TMethodNameTable; PMethodNameTable = ^TMethodNameTable;
TPointerArray = packed array[0..9999999] of Pointer; TPointerArray = packed array[0..9999999] of Pointer;
PPointerArray = ^TPointerArray; PPointerArray = ^TPointerArray;
procedure RegisterWSComponent(const AComponent: TComponentClass; procedure RegisterWSComponent(const AComponent: TComponentClass;
const AWSComponent: TWSLCLComponentClass; const AWSComponent: TWSLCLComponentClass;
const AWSPrivate: TWSPrivateClass = nil); const AWSPrivate: TWSPrivateClass = nil);
function GetNode(const AClass: TClass): PClassNode; function GetNode(const AClass: TClass): PClassNode;
var var
idx: Integer; idx: Integer;
Name: String; Name: String;
begin begin
if (AClass = nil) if (AClass = nil)
or not (AClass.InheritsFrom(TLCLComponent)) or not (AClass.InheritsFrom(TLCLComponent))
then begin then begin
Result := nil; Result := nil;
Exit; Exit;
end; end;
Name := AClass.ClassName; Name := AClass.ClassName;
idx := MComponentIndex.IndexOf(Name); idx := MComponentIndex.IndexOf(Name);
if idx = -1 if idx = -1
then begin then begin
New(Result); New(Result);
Result^.LCLClass := TComponentClass(AClass); Result^.LCLClass := TComponentClass(AClass);
@ -184,7 +184,7 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
Result := PClassNode(MComponentIndex.Objects[idx]); Result := PClassNode(MComponentIndex.Objects[idx]);
end; end;
end; end;
function FindParentWSClassNode(const ANode: PClassNode): PClassNode; function FindParentWSClassNode(const ANode: PClassNode): PClassNode;
begin begin
Result := ANode^.Parent; Result := ANode^.Parent;
@ -194,14 +194,14 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
Result := Result^.Parent; Result := Result^.Parent;
end; end;
Result := nil; Result := nil;
end; end;
function FindCommonAncestor(const AClass1, AClass2: TClass): TClass; function FindCommonAncestor(const AClass1, AClass2: TClass): TClass;
begin begin
Result := AClass1; Result := AClass1;
if AClass2.InheritsFrom(Result) if AClass2.InheritsFrom(Result)
then Exit; then Exit;
Result := AClass2; Result := AClass2;
while Result <> nil do while Result <> nil do
begin begin
@ -209,10 +209,10 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
then Exit; then Exit;
Result := Result.ClassParent; Result := Result.ClassParent;
end; end;
Result := nil; Result := nil;
end; end;
procedure CreateVClass(const ANode: PClassNode); procedure CreateVClass(const ANode: PClassNode);
var var
ParentWSNode: PClassNode; ParentWSNode: PClassNode;
@ -220,9 +220,9 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
Vvmt, Cvmt, Pvmt: PPointerArray; Vvmt, Cvmt, Pvmt: PPointerArray;
Cmnt: PMethodNameTable; Cmnt: PMethodNameTable;
SearchAddr: Pointer; SearchAddr: Pointer;
n, idx: Integer; n, idx: Integer;
WSPrivate: TClass; WSPrivate: TClass;
Processed: array[0..VIRTUAL_VMT_COUNT-1] of Boolean; Processed: array[0..VIRTUAL_VMT_COUNT-1] of Boolean;
{$IFDEF VerboseWSRegistration} {$IFDEF VerboseWSRegistration}
Indent: String; Indent: String;
{$ENDIF} {$ENDIF}
@ -245,7 +245,7 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
// Initially copy the WSClass // Initially copy the WSClass
// Tricky part, the source may get beyond read mem limit // Tricky part, the source may get beyond read mem limit
Move(Pointer(ANode^.WSClass)^, ANode^.VClass^, VIRTUAL_VMT_SIZE); Move(Pointer(ANode^.WSClass)^, ANode^.VClass^, VIRTUAL_VMT_SIZE);
// Set WSPrivate class // Set WSPrivate class
ParentWSNode := FindParentWSClassNode(ANode); ParentWSNode := FindParentWSClassNode(ANode);
if ParentWSNode = nil if ParentWSNode = nil
@ -257,7 +257,7 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
{$ENDIF} {$ENDIF}
Exit; Exit;
end; end;
if WSPrivate = TWSPrivate if WSPrivate = TWSPrivate
then begin then begin
if ParentWSNode^.VClass = nil if ParentWSNode^.VClass = nil
@ -280,11 +280,11 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
DebugLn('Common: ', CommonClass.ClassName); DebugLn('Common: ', CommonClass.ClassName);
Indent := ''; Indent := '';
{$ENDIF} {$ENDIF}
Vvmt := ANode^.VClass + vmtMethodStart; Vvmt := ANode^.VClass + vmtMethodStart;
Pvmt := ParentWSNode^.VClass + vmtMethodStart; Pvmt := ParentWSNode^.VClass + vmtMethodStart;
FillChar(Processed[0], SizeOf(Processed), 0); FillChar(Processed[0], SizeOf(Processed), 0);
while CommonClass <> nil do while CommonClass <> nil do
begin begin
Cmnt := PPointer(Pointer(CommonClass) + vmtMethodTable)^; Cmnt := PPointer(Pointer(CommonClass) + vmtMethodTable)^;
@ -297,14 +297,14 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
Cvmt := Pointer(CommonClass) + vmtMethodStart; Cvmt := Pointer(CommonClass) + vmtMethodStart;
Assert(Cmnt^.Count < VIRTUAL_VMT_COUNT, 'MethodTable count is larger that assumed VIRTUAL_VMT_COUNT'); Assert(Cmnt^.Count < VIRTUAL_VMT_COUNT, 'MethodTable count is larger that assumed VIRTUAL_VMT_COUNT');
// Loop though the VMT to see what is overridden // Loop though the VMT to see what is overridden
for n := 0 to Cmnt^.Count - 1 do for n := 0 to Cmnt^.Count - 1 do
begin begin
{$IFDEF VerboseWSRegistration} {$IFDEF VerboseWSRegistration}
DebugLn(Indent, 'Search: ', Cmnt^.Entries[n].Name^); DebugLn(Indent, 'Search: ', Cmnt^.Entries[n].Name^);
{$ENDIF} {$ENDIF}
SearchAddr := Cmnt^.Entries[n].Addr; SearchAddr := Cmnt^.Entries[n].Addr;
for idx := 0 to VIRTUAL_VMT_COUNT - 1 do for idx := 0 to VIRTUAL_VMT_COUNT - 1 do
begin begin
@ -312,9 +312,9 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
then begin then begin
{$IFDEF VerboseWSRegistration} {$IFDEF VerboseWSRegistration}
DebugLn(Indent, 'Found at index: ', IntToStr(idx)); DebugLn(Indent, 'Found at index: ', IntToStr(idx));
{$ENDIF} {$ENDIF}
if Processed[idx] if Processed[idx]
then begin then begin
{$IFDEF VerboseWSRegistration} {$IFDEF VerboseWSRegistration}
DebugLn(Indent, 'Procesed -> skipping'); DebugLn(Indent, 'Procesed -> skipping');
@ -322,7 +322,7 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
Break; Break;
end; end;
Processed[idx] := True; Processed[idx] := True;
if (Vvmt^[idx] = SearchAddr) //original if (Vvmt^[idx] = SearchAddr) //original
and (Pvmt^[idx] <> SearchAddr) //overridden by parent and (Pvmt^[idx] <> SearchAddr) //overridden by parent
then begin then begin
@ -331,7 +331,7 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
{$ENDIF} {$ENDIF}
Vvmt^[idx] := Pvmt^[idx]; Vvmt^[idx] := Pvmt^[idx];
end; end;
Break; Break;
end; end;
if idx = VIRTUAL_VMT_COUNT - 1 if idx = VIRTUAL_VMT_COUNT - 1
@ -344,25 +344,25 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
end; end;
CommonClass := Commonclass.ClassParent; CommonClass := Commonclass.ClassParent;
end; end;
// Adjust classname // Adjust classname
ANode^.VClassName := '(V)' + ANode^.WSClass.ClassName; ANode^.VClassName := '(V)' + ANode^.WSClass.ClassName;
PPointer(ANode^.VClass + vmtClassName)^ := @ANode^.VClassName; PPointer(ANode^.VClass + vmtClassName)^ := @ANode^.VClassName;
// Adjust classparent // Adjust classparent
PPointer(ANode^.VClass + vmtParent)^ := PPointer(Pointer(ParentWSNode^.WSClass) + vmtParent)^; PPointer(ANode^.VClass + vmtParent)^ := PPointer(Pointer(ParentWSNode^.WSClass) + vmtParent)^;
// Delete methodtable entry // Delete methodtable entry
PPointer(ANode^.VClass + vmtMethodTable)^ := nil; PPointer(ANode^.VClass + vmtMethodTable)^ := nil;
end; end;
procedure UpdateChildren(const ANode: PClassNode); procedure UpdateChildren(const ANode: PClassNode);
var var
Node: PClassNode; Node: PClassNode;
begin begin
Node := ANode^.Child; Node := ANode^.Child;
while Node <> nil do while Node <> nil do
begin begin
if Node^.WSClass <> nil if Node^.WSClass <> nil
then begin then begin
{$IFDEF VerboseWSRegistration} {$IFDEF VerboseWSRegistration}
DebugLn('Update VClass for: ', Node^.WSClass.ClassName); DebugLn('Update VClass for: ', Node^.WSClass.ClassName);
{$ENDIF} {$ENDIF}
@ -372,22 +372,22 @@ procedure RegisterWSComponent(const AComponent: TComponentClass;
Node := Node^.Sibling; Node := Node^.Sibling;
end; end;
end; end;
var var
Node: PClassNode; Node: PClassNode;
begin begin
Node := GetNode(AComponent); Node := GetNode(AComponent);
if Node = nil then Exit; if Node = nil then Exit;
if Node^.WSClass = nil if Node^.WSClass = nil
then MWSRegisterIndex.AddObject(AComponent.ClassName, TObject(Node)); then MWSRegisterIndex.AddObject(AComponent.ClassName, TObject(Node));
Node^.WSClass := AWSComponent; Node^.WSClass := AWSComponent;
{$IFDEF VerboseWSRegistration} {$IFDEF VerboseWSRegistration}
DebugLn('Create VClass for: ', Node^.WSClass.ClassName); DebugLn('Create VClass for: ', Node^.WSClass.ClassName);
{$ENDIF} {$ENDIF}
CreateVClass(Node); CreateVClass(Node);
// Since child classes may depend on us, recreate them // Since child classes may depend on us, recreate them
UpdateChildren(Node); UpdateChildren(Node);
end; end;
@ -404,7 +404,7 @@ begin
end; end;
procedure DoFinalization; procedure DoFinalization;
var var
n: Integer; n: Integer;
Node: PClassNode; Node: PClassNode;
begin begin