Работа с указателями, память

Code:

{©Drkb v.3(2007): drkb ru}

var

  p1 : ^String;

  s1 : String;

begin

  s1 := 'NotTest';

  new (p1);

  p1 := @s1;

  p1^ := 'Test';

  Label1.Caption := s1

Code:

function CreateVariantPtr(_Value: variant): pVariant;

begin

GetMem(Result, SizeOf(Variant));

Result^ := _Value;

end;

Code:

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls;

type

TForm1 = class(TForm)

   Button1: TButton;

   procedure Button1Click(Sender: TObject);

private

   { Private declarations }

public

   { Public declarations }

end;

var

Form1: TForm1;

CurrProc: LongInt;

MyVal: LongInt;

implementation

uses Unit2;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

var

NewProc: LongInt;

MyString: string;

begin

CurrProc := 2; { начальная точка в таблице методов }

MyVal := 0; { вспомогательная переменная }

NewProc := 0;

   { возвращаемое значение для следующего индекса в таблице методов }

while CurrProc < 6do

begin

   { выполняем текущий индекс в таблице методов и получаем следующую процедуру }

   NewProc := ProcTable[CurrProc](MyVal);

   { просто показываем значения NewProc и CurrProc }

   FmtStr(MyString, 'NewProc [%d] CurrProc [%d]', [NewProc, CurrProc]);

   MessageDlg(MyString, mtInformation, [mbOK], 0);

   { присваиваем текущую процедуру возвращаемой процедуре }

   CurrProc := NewProc;

end;

end;

end.

Code:

{ Это простой пример, определяющий массив указателей на функции }

interface

type

{ определяем Procs как функцию }

Procs = function(var ProcNum: LongInt): LongInt;

var

{ объявляем массив указателей на функции }

ProcTable: array[1..5] of Procs;

{ определения интерфейсов функций }

function Proc1(var MyVal: LongInt): LongInt; far;

function Proc2(var MyVal: LongInt): LongInt; far;

function Proc3(var MyVal: LongInt): LongInt; far;

function Proc4(var MyVal: LongInt): LongInt; far;

function Proc5(var MyVal: LongInt): LongInt; far;

implementation

uses Dialogs;

function Proc1(var MyVal: LongInt): LongInt;

begin

MessageDlg('Процедура 1', mtInformation, [mbOK], 0);

Proc1 := 6;

end;

function Proc2(var MyVal: LongInt): LongInt;

begin

MessageDlg('Процедура 2', mtInformation, [mbOK], 0);

Proc2 := 3;

end;

function Proc3(var MyVal: LongInt): LongInt;

begin

MessageDlg('Процедура 3', mtInformation, [mbOK], 0);

Proc3 := 4;

end;

function Proc4(var MyVal: LongInt): LongInt;

begin

MessageDlg('Процедура 4', mtInformation, [mbOK], 0);

Proc4 := 5;

end;

function Proc5(var MyVal: LongInt): LongInt;

begin

MessageDlg('Процедура 5', mtInformation, [mbOK], 0);

Proc5 := 1;

end;

initialization

{ инициализируем содержание массива указателей на функции }

@ProcTable[1] := @Proc1;

@ProcTable[2] := @Proc2;

@ProcTable[3] := @Proc3;

@ProcTable[4] := @Proc4;

@ProcTable[5] := @Proc5;

end.

Code:

type

TBaseForm = class(TForm)

public

   procedure Method1; virtual; abstract;

end;

type

TDerivedForm1 = class(TBaseForm)

public

   procedure Method1; override;

end;

TDerivedForm2 = class(TBaseForm)

public

   procedure Method1; override;

end;

procedure TDerivedForm1.Method1;

begin

....

end;

procedure TDerivedForm2.Method1;

begin

....

end;

{Для вызова функции из вашего toolbar,

получите активную в настоящий момент форму и вызовите Method1}

procedure OnButtonClick;

var

AForm: TBaseForm;

begin

AForm := ActiveForm as TBaseForm;

AForm.Method1;

end;

Code:

unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  StdCtrls;

type

  TMyObjectPtr = ^TMyObject;

  TMyObject = record

    First_Name: String[20];

    Last_Name: String[20];

    Next: TMyObjectPtr;

  end;

type

  TForm1 = class(TForm)

    bSortByLastName: TButton;

    bDisplay: TButton;

    bPopulate: TButton;

    ListBox1: TListBox;

    bClear: TButton;

    procedure bSortByLastNameClick(Sender: TObject);

    procedure bPopulateClick(Sender: TObject);

    procedure bDisplayClick(Sender: TObject);

    procedure bClearClick(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

var

  Form1: TForm1;

  pStartOfList: TMyObjectPtr = nil;

{List manipulation routines}

procedure SortMyObjectListByLastName(var aStartOfList: TMyObjectPtr);

function CreateMyObject(aFirstName, aLastName: String): TMyObjectPtr;

procedure AppendMyObject(var aCurrentItem, aNewItem: TMyObjectPtr);

procedure ClearMyObjectList(var aMyObject: TMyObjectPtr);

procedure RemoveMyObject(var aStartOfList, aRemoveMe: TMyObjectPtr);

function AreInAlphaOrder(aString1, aString2: String): Boolean;

implementation

{$R *.DFM}

procedure TForm1.bClearClick(Sender: TObject);

begin

  ClearMyObjectList(pStartOfList);

end;

procedure TForm1.bPopulateClick(Sender: TObject);

var

  pNew: TMyObjectPtr;

begin

  {Initialize the list with some static data}

  pNew := CreateMyObject('Suzy','Martinez');

  AppendMyObject(pStartOfList, pNew);

  pNew := CreateMyObject('John','Sanchez');

  AppendMyObject(pStartOfList, pNew);

  pNew := CreateMyObject('Mike','Rodriguez');

  AppendMyObject(pStartOfList, pNew);

  pNew := CreateMyObject('Mary','Sosa');

  AppendMyObject(pStartOfList, pNew);

  pNew := CreateMyObject('Betty','Hayek');

  AppendMyObject(pStartOfList, pNew);

  pNew := CreateMyObject('Luke','Smith');

  AppendMyObject(pStartOfList, pNew);

  pNew := CreateMyObject('John','Sosa');

  AppendMyObject(pStartOfList, pNew);

end;

procedure TForm1.bSortByLastNameClick(Sender: TObject);

begin

  SortMyObjectListByLastName(pStartOfList);

end;

procedure TForm1.bDisplayClick(Sender: TObject);

var

  pTemp: TMyObjectPtr;

begin

  {Display the list items}

  ListBox1.Items.Clear;

  pTemp := pStartOfList;

  while pTemp <> nildo

  begin

    ListBox1.Items.Add(pTemp^.Last_Name + ', ' + pTemp.First_Name);

    pTemp := pTemp^.Next;

  end;

end;

procedure ClearMyObjectList(var aMyObject: TMyObjectPtr);

var

  TempMyObject: TMyObjectPtr;

begin

  {Free the memory used by the list items}

  TempMyObject := aMyObject;

  while aMyObject <> nildo

  begin

    aMyObject := aMyObject^.Next;

    Dispose(TempMyObject);

    TempMyObject := aMyObject;

  end;

end;

function CreateMyObject(aFirstName, aLastName: String): TMyObjectPtr;

begin

  {Instantiate a new list item}

  new(result);

  result^.First_Name := aFirstName;

  result^.Last_Name := aLastName;

  result^.Next := nil;

end;

procedure SortMyObjectListByLastName(var aStartOfList: TMyObjectPtr);

var

  aSortedListStart, aSearch, aBest: TMyObjectPtr;

begin

  {Sort the list by the Last_Name "field"}

  aSortedListStart := nil;

  while (aStartOfList <> nil) do

  begin

    aSearch := aStartOfList;

    aBest := aSearch;

    while aSearch^.Next <> nildo

    begin

      ifnot AreInAlphaOrder(aBest^.Last_Name, aSearch^.Last_Name) then

        aBest := aSearch;

      aSearch := aSearch^.Next;

    end;

    RemoveMyObject(aStartOfList, aBest);

    AppendMyObject(aSortedListStart, aBest);

  end;

  aStartOfList := aSortedListStart;

end;

procedure AppendMyObject(var aCurrentItem, aNewItem: TMyObjectPtr);

begin

  {Recursive function that appends the new item to the end of the list}

  if aCurrentItem = nilthen

    aCurrentItem := aNewItem

  else

    AppendMyObject(aCurrentItem^.Next, aNewItem);

end;

procedure RemoveMyObject(var aStartOfList, aRemoveMe: TMyObjectPtr);

var

  pTemp: TMyObjectPtr;

begin

  {Removes a specific item from the list and collapses the empty spot.}

  pTemp := aStartOfList;

  if pTemp = aRemoveMe then

    aStartOfList := aStartOfList^.Next

  else

  begin

    while (pTemp^.Next <> aRemoveMe) and (pTemp^.Next <> nil) do

      pTemp := pTemp^.Next;

    if pTemp = nilthen Exit; //Shouldn't ever happen

   if pTemp^.Next = nilthen Exit; //Shouldn't ever happen

   pTemp^.Next := aRemoveMe^.Next;

  end;

  aRemoveMe^.Next := nil;

end;

function AreInAlphaOrder(aString1, aString2: String): Boolean;

var

  i: Integer;

begin

  {Returns True if aString1 should come before aString2 in an alphabetic ascending sort}

  Result := True;

  while Length(aString2) < Length(aString1) do aString2 := aString2 + '!';

  while Length(aString1) < Length(aString2) do aString1 := aString1 + '!';

  for i := 1to Length(aString1) do

  begin

    if aString1[i] > aString2[i] then Result := False;

    if aString1[i] <> aString2[i] then break;

  end;

end;

end.

Code:

Зависимости: System

Автор:       Григорий Ситнин, gregor gregor.ru, Москва

Copyright:   Григорий Ситнин, 2003

Дата:        8 июля 2003 г.

***************************************************** }

function IncPtr(APointer: pointer; AHowMuch: cardinal = 1): pointer;

begin

//*** Конвертируем указатель в Cardinal, увеличиваем значение адреса,

//*** и конвертируем обратно в указатель, который и возвращаем.

//**! Внимание, функция не выделяет никаких блоков памяти,

//**! она просто работает с указателем.

Result := Ptr(cardinal(APointer) + AHowMuch);

end;

Пример использования:

{$APPTYPE CONSOLE}

program testptr;

uses SysUtils, uIncPtr; //*** Модуль uIncPtr содержит функцию IncPtr

var

ptr1, ptr2: pointer;

begin

ptr1 := AllocMem(255);

ptr2 := incptr(ptr1, 10);

writeln('ptr1 : ', cardinal(ptr1));

//*** Напечатать увеличенный на 10 указатель ptr1

writeln('ptr2 (+10): ', cardinal(ptr2));

FreeMem(ptr1, 255)

end.