Oh Mann,
ich hab mir da einen abgebrochen mit z.B. dem da: (TMuMPersistent ist eine von TList abgeleitete Klasse
Code: Alles auswählen
function TMuMPersistent.FirstThat (Test: Pointer) : Pointer;
var
item : Pointer;
i : Integer;
begin
result := nil;
i := 0;
while i < count do
begin
item := items[i];
if assigned (item) then
if boolean(byte(ptruint(callPointerIntLocal(test, get_caller_frame(get_frame), item, i)))) then
begin
Result := Item;
exit;
end;
inc (i)
end;
end;
Die mit
is nested deklarierte Prozedur oder Funktion bekommt auch wunderbar den Stackframe der aufrufenden Prozedur, selbst wenn sie sich selbst rekursiv aufruft.
Beachte hier den rekursiven Aufruf von @all.
Klappt wunderbar.
Hier ein komplettes Codebeispiel. Das Formular braucht nur einen Button und ein Memo.
Code: Alles auswählen
unit Unit1;
{$mode objfpc}{$H+}
{$ModeSwitch nestedprocvars} // -- Der muss gesetzt sein
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
TMyBase = class;
TForEachProcedure = procedure(Item : TMyBase) is Nested;
TFirstThatFunction = function(Item : TMyBase) : boolean is Nested;
{ TMyBase }
TMyBase = class ( TList )
fName : string;
constructor Create(aName : string);
function Get(Index : Integer) : TMyBase;
procedure Put(Index : Integer; Item : TMyBase);
procedure ForEach(All : TForEachProcedure);
function FirstThat(Test : TFirstThatFunction) : TMyBase;
property Items[Index : Integer] : TMyBase read Get write Put; default;
end;
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
fData : TMyBase;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TMyBase }
constructor TMyBase.Create(aName: string);
begin
inherited Create;
fName := aName;
end;
function TMyBase.Get(Index: Integer): TMyBase;
begin
Result := TMyBase(inherited Get(Index));
end;
procedure TMyBase.Put(Index: Integer; Item: TMyBase);
begin
inherited Put(Index, Item);
end;
procedure TMyBase.ForEach(All: TForEachProcedure);
var cnt : Integer;
begin
for cnt := 0 to Count - 1 do
All(Items[cnt]);
end;
function TMyBase.FirstThat(Test: TFirstThatFunction): TMyBase;
var i : integer;
begin
for i := 0 to Count - 1 do
begin
Result := Items[i];
if Test(Result) then exit;
end;
Result := nil;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
var sub : TMyBase;
begin
fData := TMyBase.Create('Basis');
fData.Add(TMyBase.Create('SubItem 1'));
sub := TMyBase.Create('SubItem 2');
fData.Add(sub);
sub.Add(TMyBase.Create('sub sub'));
fData.Add(TMyBase.Create('SubItem 3'));
fData.Add(TMyBase.Create('SubItem 4'));
end;
procedure TForm1.Button1Click(Sender: TObject);
var ParentName : string;
procedure All(Item : TMyBase);
var MyParent : string;
begin
Memo1.Lines.Add(ParentName + ' ' + Item.fName);
MyParent := ParentName;
ParentName := ParentName + ' ' + Item.fName;
Item.ForEach(@All);
ParentName := MyParent;
end;
function test(Item : TMyBase) : boolean;
begin
Result := Item.fName = ParentName;
end;
var Item : TMyBase;
begin
ParentName := fData.fName;
fData.ForEach(@All);
ParentName := fData[2].fName;
Item := fData.FirstThat(@test);
if (Item <> nil) then
Memo1.Lines.Add('Found subitem with same Name' + Item.fName)
else
Memo1.Lines.Add('Nothing found');
end;
end.
In dem Memo steht nachher:
Code: Alles auswählen
Basis SubItem 1
Basis SubItem 2
Basis SubItem 2 sub sub
Basis SubItem 3
Basis SubItem 4
Found subitem with same NameSubItem 3
und das allerbeste ist dabei, daß ich die Typprüfungen des Compilers nicht mit dem Pointergefrickel umgehen muß.
.
Verein
Links
Suche