Generic function to increase array of pointers - arrays

I'm working in a code that has a data structure like this:
type
TData1 = record
IntField: Integer;
StrField: string;
end;
TData2 = record
DateField: TDateTime;
StrField: string;
end;
var
AData1 = array of ^TData1;
AData2 = array of ^TData2;
Sometimes I have to add an element to one of that arrays, like this:
L := Length(AData1);
SetLength(AData1, L + 1);
New(AData1[L]);
How can I write a procedure that does that job of increasing the array size and allocating memory for a new item that works for any kind of pointer? And it must be done without changing the definitions of the records (TData1, TData2) and the arrays (AData1, AData2), so it won't break existing code.
Ps: I don't have much background with pointers and that kind of programming, I'd certainly use objects and dynamic linked lists, but in this case it's a legacy code and I can't change it, at least for now.

Update:
This is not a full answer. Using TDynArray as mentioned by David may solve your problem.
Using RTTI I made a another solution for you. It is a generic solution and you can easily add more functions/capabilities. It will preserve your type declarations. Example of adding/removing records is included.
The record TDynPtArray handles any dynamic array of pointers to records. It is initialized with an Init call:
DPA.Init(TypeInfo(TData1), AData1);
Data1 := DPA.Add; // Adds a record with default values and
// returns a pointer to the record
DPA.Remove; // Finalizes/deallocates the last record and
// shrinks the dynamic array
-
uses
Windows,System.SysUtils,System.TypInfo;
Type
TPtArray = array of Pointer;
PPtArray = ^TPtArray;
TDynPtArray = record
private
FDynArray: PPtArray;
FTypeInfo: PTypeInfo;
FTypeData: PTypeData;
public
constructor Init( T: Pointer; var dynArray);
function Add : Pointer;
procedure Remove;
procedure Clear;
end;
constructor TDynPtArray.Init(T: Pointer; var dynArray);
begin
FTypeInfo := T;
if (FTypeInfo^.Kind <> tkRecord) then
raise Exception.CreateFmt('%s is not a record',[FTypeInfo^.Name]);
FTypeData := GetTypeData( FTypeInfo);
FDynArray := #dynArray;
end;
function TDynPtArray.Add: Pointer;
var
L: integer;
begin
L := Length(FDynArray^);
SetLength(FDynArray^,L+1);
GetMem( FDynArray^[L], FTypeData^.elSize);
ZeroMemory( FDynArray^[L], FTypeData^.elSize);
Result := FDynArray^[L];
end;
procedure RecordClear(var Dest; TypeInfo: pointer);
asm
{$ifdef CPUX64}
.NOFRAME
{$endif}
jmp System.#FinalizeRecord
end;
procedure TDynPtArray.Remove;
var
L: integer;
begin
L := Length(FDynArray^);
if (L = 0) then
exit;
RecordClear( FDynArray^[L-1]^,FTypeInfo); // Finalize record
FreeMem( FDynArray^[L-1], FTypeData^.elSize);
SetLength(FDynArray^,L-1);
end;
procedure TDynPtArray.Clear;
begin
while (Length(FDynArray^) <> 0) do
Self.Remove;
end;
And a little test:
type
PData1 = ^TData1;
TData1 = record
IntField: Integer;
StrField: string;
end;
TData1Arr = array of PData1;
var
AData1: TData1Arr;
Data1: PData1;
DPA: TDynPtArray;
begin
DPA.Init(TypeInfo(TData1), AData1);
Data1:= DPA.Add;
Data1^.StrField := '111';
WriteLn(Data1^.IntField);
WriteLn(Data1^.StrField);
DPA.Clear;
ReadLn;
end.

Related

How to output an array that has nested arrays in Pascal

I'm creating a basic concept of a music player using Pascal, but I'm struggling to display the albums inside it. The error I got says "(134, 29) Error: Can't read or write variables of this type". I'm assuming it's saying that because I'm using an array within an array, and it's having a hard time displaying both at the same time (although I only want it to display the albums, not the tracks as well).
Here's what my code looks like:
function ReadAllTrack(prompt: String): Tracks;
var
i: Integer;
trackArray: Array of Track;
trackCount: Integer;
begin
WriteLn(prompt);
trackCount := ReadIntegerGreaterThan1('Please enter the number of tracks you would like to add: ');
Setlength(trackArray, trackCount);
for i := 0 to trackCount - 1 do
begin
WriteLn('Enter the details for your track:');
trackArray[i] := ReadTrack();
end;
result := trackArray;
end;
function ReadAlbum(): Album;
begin
result.albumName := ReadString('Album name: ');
result.artistName := ReadString('Artist name: ');
result.albumGenre := ReadGenre('Genre:');
result.trackCollection := ReadAllTrack('Track Collection:');
end;
function ReadAllAlbums(): Albums;
var
i: Integer;
albumArray: Array of Album;
albumCount: Integer;
begin
albumCount := ReadIntegerGreaterThan1('Please enter the number of albums you would like to add: ');
Setlength(albumArray, albumCount);
for i := 0 to albumCount - 1 do
begin
WriteLn('Enter the details for your album:');
albumArray[i] := ReadAlbum();
end;
result := albumArray;
end;
procedure DisplayAlbumOptions(listOfAllAlbums: Albums);
var
userInput: Integer;
begin
WriteLn('1. Display all albums');
WriteLn('2. Display all albums for a genre');
userInput := ReadIntegerRange('Please enter a number (1, 2) to select: ', 1, 2);
case userInput of
1: WriteLn(listOfAllAlbums); //Error: Can't read or write variables of this type
end;
end;
Basically what this does is it will ask the user showing 5 options:
1. Add albums
2. Display albums
etc
If the user selects 1, the program will ask the user to input the number of albums they want to input. Then for each album it'll ask them to enter the details, and then the tracks.
Then if the user selects 2, the program will ask the user to choose either display every single album there is, or display all albums for a single genre (I'll be working on this one after solving this problem). At first I thought it would be just as simple as WriteLn(TheAlbumArray); but turns out it was more complicated than I thought because I don't think it's possible for the program to display it this way. I tried separating the albums and tracks so that it would only display the albums when I use WriteLn(TheAlbumArray); but it wasn't possible because the tracks still have to be "inside" the album so that when I display the albums and select one of them, it would then display the tracks....
Any help or suggestion for this and/or the second will be much appreciated ^^
Your original question contained a lot of superfluous detail. After the edit, you removed the type declarations, but kept much of the superfluous detail.
However, it is possible to discern the problem you are passing an array of record to Writeln. The Writeln function can accept only certain simple types as arguments, e.g. strings, numerical types, boolean. You certainly cannot pass an array to Writeln. You must iterate over the array and process each member individually.
So you might try
for i := low(listOfAllAlbums) to high(listOfAllAlbums) do
WriteLn(listOfAllAlbums[i]);
But that does not work either, because listOfAllAlbums[i] is a record, and a record is a compound type which cannot be passed to Writeln. So you need to process the record separately. If you want to display just the title, then you write:
for i := low(listOfAllAlbums) to high(listOfAllAlbums) do
WriteLn(listOfAllAlbums[i].albumName);
If you want to print the track titles too then you need to iterate over the array contained in the record.
for i := low(listOfAllAlbums) to high(listOfAllAlbums) do
begin
WriteLn(listOfAllAlbums[i].albumName);
for j := low(trackCollection) to high(trackCollection) do
WriteLn(listOfAllAlbums[i].trackCollection[j]);
end;
It is impossible to use composite types (arrays, records, ...) in Read[ln] and Write[ln] procedures.
To make your code more transparent you could to create type helper for your array(s) and use well-known AsString property. Here is example for simple array of Integer:
program foo;
{$mode objfpc}{$H+}
{$modeswitch typehelpers}
uses
Classes, SysUtils;
type
TMyArray = array of Integer;
TMyArrayHelper = type helper for TMyArray
private
function GetAsString: string;
procedure SetAsString(const AValue: string);
public
property AsString: string read GetAsString write SetAsString;
end;
function TMyArrayHelper.GetAsString: string;
var
i: Integer;
begin
Result := '';
for i in Self do
begin
if Result <> '' then
Result := Result + ', ';
Result := Result + IntToStr(i);
end;
Result := '[' + Result + ']';
end;
// Relatively simple parser
// Fill free to implement ones for your array type
procedure TMyArrayHelper.SetAsString(const AValue: string);
var
tmp, s: string;
items: TStringArray;
i: Integer;
begin
tmp := Trim(AValue);
if not (tmp.StartsWith('[') and tmp.EndsWith(']')) then
raise Exception.CreateFmt('Invalid array literal format: "%s"', [tmp]);
tmp := tmp.Trim(['[', ']']);
items := tmp.Split([',']);
for s in items do
try
StrToInt(s);
except
on e: Exception do
raise Exception.CreateFmt('Invalid integer literal: "%s"', [s]);
end;
SetLength(Self, Length(items));
for i := 0 to Length(items) - 1 do
Self[i] := StrToInt(items[i]);
end;
var
a1, a2: TMyArray;
begin
a1.AsString := '[1,2,3,5]';
Writeln('a1 = ', a1.AsString);
a2.AsString := a1.AsString;
a2[1] := 999;
Writeln('a2 = ', a2.AsString);
end.
Helper types in FreePascal
TStringHelper in SysUtils unit

Delphi - searching for object in array

I have function to search for TItem (my own class) in array of TItem.
function IndexOfArray(const Value: TItem; Things: array of TItem): integer;
var
i: integer;
begin
Result := -1;
for i := Low(Things) to High(Things) do
if Value = Things[i] then
begin
Result := i;
Break;
end;
end;
It's working for array of TItem. But I want to use it with TItem or TIamge or TLabel. I tried TObject or TComponent as input parameters of this method, but compiler shouts:
E2010 Incompatible types: 'array of TComponent' and 'Dynamic array'
The array of TLabel/TImage/TItem MUST be dynamic. Any ideas please?
TArray.BinarySearch does that for you.
if TArray.BinarySearch<TLabel>(Labels,LabelLoaded,index) then
// Index holds the index of the found item
Note: BinarySearch requires that the array be sorted.
If you just want to compare the pointer value of the objects, here is an example:
Type
TMyArray = record
class function IndexOfArray<T:Class>(const value: T; const Things: array of T): Integer; static;
end;
class function TMyArray.IndexOfArray<T>(const value: T; const Things: array of T): Integer;
var
i: Integer;
begin
for i := 0 to High(Things) do
if value = Things[i] then
Exit(i);
Result := -1;
end;
If you want to write your own bicycle you can try something like this:
type
myAr = array of TObject;
. . .
function IndexOfArray(const Value: TObject; Things: myAr): integer;
var
i: integer;
begin
Result := -1;
for i := Low(Things) to High(Things) do
if (Things[i] is Value.ClassType) and // don't sure that this is nessesary
(Value = Things[i]) then
begin
Result := i;
Break;
end;
end;
procedure someProc;
var
ar : myAr;
lbl : TLabel;
i : integer;
begin
SetLength(ar, 10);
for I := Low(ar) to High(ar) do
ar[i] := TLabel.Create(self);
lbl := TLabel.Create(Self);
i := IndexOfArray(lbl, ar);
end;
Also you can use standard System.Generics.Collections.TArray.BinarySearch class.

Cast static array to open array of different element type

(I already asked this at CodeReview where it got closed as off-topic. Hopefully it's on-topic here.)
I have a static arrays of a derived type (like LabelsA: array[0..3] of TLabel; in the following sample code) and a routine accepting an open array of the base type (like procedure DoSomethingWithControls(const AControls: array of TControl);), and I want to call DoSomethingWithControls with those static arrays. Please see my sample:
procedure DoSomethingWithControls(const AControls: array of TControl);
var
i: Integer;
begin
for i := Low(AControls) to High(AControls) do
Writeln(AControls[i].Name);
end;
procedure Test;
var
LabelsA: array[0..3] of TLabel;
LabelsB: array[0..1] of TLabel;
procedure Variant1;
type
TArray1 = array[Low(LabelsA)..High(LabelsA)] of TControl;
TArray2 = array[Low(LabelsB)..High(LabelsB)] of TControl;
begin
DoSomethingWithControls(TArray1(LabelsA));
DoSomethingWithControls(TArray2(LabelsB));
end;
procedure Variant2;
type
TControlArray = array[0..Pred(MaxInt div SizeOf(TControl))] of TControl;
PControlArray = ^TControlArray;
begin
DoSomethingWithControls(Slice(PControlArray(#LabelsA)^, Length(LabelsA)));
DoSomethingWithControls(Slice(PControlArray(#LabelsB)^, Length(LabelsB)));
end;
procedure Variant3;
var
ControlsA: array[Low(LabelsA)..High(LabelsA)] of TControl absolute LabelsA;
ControlsB: array[Low(LabelsB)..High(LabelsB)] of TControl absolute LabelsB;
begin
DoSomethingWithControls(ControlsA);
DoSomethingWithControls(ControlsB);
end;
begin
Variant1;
Variant2;
Variant3;
end;
There are some possible variants of calling DoSomethingWithControls:
Variant 1 is quite simple but needs an "adapter" types like TArray1
for every size of TLabel array. I would like it to be more flexible.
Variant 2 is more flexible and uniform but ugly and error prone.
Variant 3 (courtesy of
TOndrej) is similar to
Variant 1 - it doesn't need an explicit cast, but Variant 1 offers a
tiny bit more compiler security if you mess something up (e.g.
getting the array bounds wrong while copy-pasting).
Any ideas how i can formulate these calls without these disadvantages (without changing the element types of the arrays)? It should work with D2007 and XE6.
These casts are all rather ugly. They will all work, but using them makes you feel dirty. It's perfectly reasonable to use a helper function:
type
TControlArray = array of TControl;
function ControlArrayFromLabelArray(const Items: array of TLabel): TControlArray;
var
i: Integer;
begin
SetLength(Result, Length(Items));
for i := 0 to high(Items) do
Result[i] := Items[i];
end;
And then you call your function like this:
DoSomethingWithControls(ControlArrayFromLabelArray(...));
Of course, this would be so much cleaner if you could use generics.
Not extremely beautiful either but you could trick the compiler like this:
procedure Variant3;
var
ControlsA: array[Low(LabelsA)..High(LabelsA)] of TControl absolute LabelsA;
begin
DoSomethingWithControls(ControlsA);
end;
Declare an overloaded procedure:
procedure DoSomethingWithControls(const AControls: array of TControl); overload;
var
i: Integer;
begin
for i := 0 to High(AControls) do
if Assigned(AControls[i]) then
Writeln(AControls[i].Name)
else
WriteLn('Control item: ',i);
end;
procedure DoSomethingWithControls(const ALabels: array of TLabel); overload;
type
TControlArray = array[0..Pred(MaxInt div SizeOf(TControl))] of TControl;
PControlArray = ^TControlArray;
begin
DoSomethingWithControls(Slice(PControlArray(#ALabels)^, Length(ALabels)));
end;
This is a general solution to your variant2. One declaration for all cases, so less prone to errors.
Below example is based on how open array parameters are internally implemented. It won't work with "typed # operator" however.
procedure Variant4;
type
TCallProc = procedure (AControls: Pointer; HighBound: Integer);
var
CallProc: TCallProc;
begin
CallProc := #DoSomethingWithControls;
CallProc(#LabelsA, Length(LabelsA) - 1);
CallProc(#LabelsB, Length(LabelsB) - 1);
end;
Passing High(Labels) for HighBound is perhaps better as long as all static arrays are 0 based.
Since a dynamic array can be passed into method as an open array, and option would be to convert the static array to a dynamic array.
If you don't mind the overhead of copying the array, consider the following:
Write a function to convert an open array of labels into a dynamic TControlArray array.
type
TControlArray = array of TControl;
{$IFOPT R+} {$DEFINE R_ON} {$R-} {$ENDIF}
function MakeControlArray(const ALabels: array of TLabel): TControlArray;
begin
SetLength(Result, Length(ALabels));
Move(ALabels[0], Result[0], Length(ALabels) * SizeOf(TObject));
end;
{$IFDEF R_ON} {$R+} {$UNDEF R_ON} {$ENDIF}
Now Variant4 can be written as:
procedure Variant4;
begin
DoSomethingWithControls(MakeControlArray(LabelsA));
DoSomethingWithControls(MakeControlArray(LabelsB));
end;
Test cases:
procedure TAdHocTests.TestLabelsToControls;
const
LLabelsA: array[0..3] of TLabel = (Pointer(0),Pointer(1),Pointer(2),Pointer(3));
var
LLoopI: Integer;
LLabelsB: array[0..9] of TLabel;
LEmptyArray: TLabelArray;
begin
for LLoopI := Low(LLabelsB) to High(LLabelsB) do
begin
LLabelsB[LLoopI] := Pointer(LLoopI);
end;
DoSomethingWithControls(MakeControlArray(LLabelsA), Length(LLabelsA));
DoSomethingWithControls(MakeControlArray(LLabelsB), Length(LLabelsB));
DoSomethingWithControls(MakeControlArray([]), 0);
DoSomethingWithControls(MakeControlArray(LEmptyArray), 0);
end;
procedure TAdHocTests.DoSomethingWithControls(
const AControls: array of TControl;
AExpectedLength: Integer);
var
LLoopI: Integer;
begin
CheckEquals(AExpectedLength, Length(AControls), 'Length incorrect');
for LLoopI := Low(AControls) to High(AControls) do
begin
CheckEquals(LLoopI, Integer(AControls[LLoopI]));
end;
end;

Returning a dynamic array from a function

I'm working with Delphi 7.
Here's my base class. The function load_for_edit() is supposed to return an array of strings which sounds like it does. The problem is not particularly here but further.
...
type
TStringArray = array of string;
...
function load_for_edit(): TStringArray;
...
numberOfFields: integer;
...
function TBaseForm.load_for_edit(): TStringArray;
var
query: TADOQuery;
i: integer;
begin
query := TADOQuery.Create(self);
query.Connection := DataModule1.ADOConnection;
query.SQL.Add('CALL get_' + self.table_name + '_id(' + self.id + ')');
query.Open;
numberOfFields := query.Fields.Count;
SetLength(result, query.Fields.Count);
for i := 0 to query.Fields.Count - 1 do
result[i] := query.Fields[i].Value.AsString;
end;
Next is the class that is a descendant of the base class and it's trying to receive an array from the base class's load_for_edit() function.
...
type
TStringArray = array of string;
...
procedure TPublisherEditForm.FormShow(Sender: TObject);
var
rec: TStringArray;
begin
inherited;
SetLength(rec, self.numberOfFields);
rec := load_for_edit(); // Compilation stops here
end;
But, the application won't compile. Delphi spits out this error message:
Incompatible types
So, what this means is that the function load_for_edit() returns a data type that is different from the variable rec's data type, though, as can be seen from their respective type declaration sections, their declarations are absolutely identical. I don't know what's going on here and what to do. Please, help me come up with a solution.
You've got two separate declarations of TStringArray (one in each unit), and they are not the same. (The fact that they're in two separate units makes them different. UnitA.TStringArray is not the same as UnitB.TStringArray, even if they're both declared as type TStringArray = array of string;.)
You need to use a single type declaration:
unit
BaseFormUnit;
interface
uses
...
type
TStringArray: array of string;
TBaseForm = class(...)
numberOfFields: Integer;
function load_for_edit: TStringArray;
end;
implementation
// Not sure here. It looks like you should use a try..finally to
// free the query after loading, but if you need to use it later
// to save the edits you should create it in the TBaseForm constructor
// and free it in the TBaseForm destructor instead, which means it
// should also be a field of the class declaration above.
function TBaseForm.load_for_edit(): TStringArray;
var
query: TADOQuery;
i: integer;
begin
query := TADOQuery.Create(self);
query.Connection := DataModule1.ADOConnection;
query.SQL.Add('CALL get_' + self.table_name + '_id(' + self.id + ')');
query.Open;
numberOfFields := query.Fields.Count;
SetLength(result, numberOfFields);
for i := 0 to numberOfFields - 1 do
Result[i] := query.Fields[i].Value.AsString;
end;
...
end.
Now your descendant class can access it:
unit
PublisherEditFormUnit;
interface
uses
... // Usual Forms, Windows, etc.
BaseFormUnit;
type
TPublisherEditForm = class(TBaseForm)
...
procedure FormShow(Sender: TObject);
end;
implementation
procedure TPublisherEditForm.FormShow(Sender: TObject);
var
rec: TStringArray;
begin
// No need to call SetLength - the base class does.
rec := load_for_edit(); // Compilation stops here
end;
...
end.

How to pass dynamic array of string to a dll library (dll and client written in d7) without ShareMem Unit?

I've read on this page that dynamic arrays need ShareMem unit to work properly.
However I would like to write a dll open for other languages.
Could anyone tell me how can I declare the function and its parameters to pass array of String?
Isn't really something like this not allowed without ShareMem?
var
templates : array of WideString;
begin
SetLength(templates, 2);
templates[0] := 'template1';
templates[1] := 'template2';
end
DLLFunction(#templates[0]);
Thanks for help!
A dynamic array of strings is already an array of PWideChar/PAnsiChar (for WideString or UnicodeString/AnsiString).
This dynamic array can be directly mapped as is, with no memory copy, from most languages, as an array of PWideChar/PAnsiChar:
From caller:
DLLFunction(length(templates),pointer(templates));
From dll:
type
TPAnsiCharArray = array[0..MaxInt div SizeOf(PAnsiChar)-1] of PAnsiChar;
PPAnsiCharArray = ^TPAnsiCharArray;
TPWideCharArray = array[0..MaxInt div SizeOf(PWideChar)-1] of PWideChar;
PPWideCharArray = ^TPWideCharArray;
procedure DLLFunction(argc: integer; argv: PPWideCharArray);
var i: integer;
begin
for i := 0 to argc-1 do
writeln(argv[i]);
end;
From a C dll for instance, you can use char **argv instead of PPAnsiCharArray and void **argv instead of PPWideCharArray.
Then you can easily convert back the PWideChar/PAnsiChar into the native string type of the language.
If you need only to write a Delphi dll, you can use
type
TAnsiStringArray = array[0..MaxInt div SizeOf(AnsiString)-1] of AnsiString;
PAnsiStringArray = ^TAnsiStringArray;
TWideStringArray = array[0..MaxInt div SizeOf(WideString)-1] of WideString;
PWideStringArray = ^TWideStringArray;
procedure DLLFunction(argc: integer; argv: PWideStringArray);
var i: integer;
begin
for i := 0 to argc-1 do
writeln(argv[i]);
end;
or even
DLLFunction(templates);
procedure DLLFunction(const templates: array of WideString);
var i: integer;
begin
for i := 0 to high(templates) do
writeln(templates[i]);
end;

Categories

Resources