How can I use varargs to print out multiple strings? I tried this but I cannot determine the size of the array. It just prints garbage.
program Project1;
{$APPTYPE CONSOLE}
{$POINTERMATH ON}
function _Print(const S: String): string; cdecl;
var
Args: Array[0..100] of Pointer absolute S;
I: Integer;
begin
I := 0;
while Args[I] <> nil do
begin
WriteLn(PString(#Args[I])^);
Inc(I);
end;
end;
const Print: function(const S: String): string; cdecl varargs = _Print;
var
A, B: String;
begin
A := 'ABC';
B := 'CDE';
Print(a, b, 'asdasd', 'fasd', ' ')
end.
A varargs function has no automated way to determine the number of arguments being passed, because only the caller knows how many parameters it is putting on the call stack. The function must determine the arguments manually, either by:
requiring the caller to pass the actual number of parameter as a fixed parameter:
function _Print(NumStrings: Integer; const Strings: string): string; cdecl;
var
Args: Array[0..100] of Pointer absolute Strings;
I: Integer;
begin
for I := 0 to NumStrings-1 do
begin
WriteLn(PString(#Strings[I])^);
end;
end;
const
Print: function(NumStrings: Integer; const Strings: string): string; cdecl varargs = _Print;
var
A, B: String;
begin
A := 'ABC';
B := 'CDE';
Print(5, a, b, 'asdasd', 'fasd', ' ');
end.
putting a sentry value at the end of the parameter list that the function can then look for. Your function is already coded for this (it is looking for a nil pointer), so just pass one:
Print(a, b, 'asdasd', 'fasd', ' ', nil);
That being said, either approach is subject to caller error and thus potentially dangerous if misused, which is why varargs-style functions are not used very often. You should consider using an open-array parameter instead:
program Project1;
{$APPTYPE CONSOLE}
{$POINTERMATH ON}
function _Print(const Args: array of string): string;
var
I: Integer;
begin
for I := Low(Args) to High(Args) do
begin
WriteLn(Args[I]);
end;
end;
const
Print: function(const Args: array of string): string = _Print;
var
A, B: String;
begin
A := 'ABC';
B := 'CDE';
Print([a, b, 'asdasd', 'fasd', ' ']);
end.
Related
While reading the documentation at Anonymous Methods in Delphi I started to wonder. I've always used something like this:
type TMathFn = Function(A, B: Integer): Integer;
var fn: TMathFn;
Always worked for me. But this document tells me to use this instead:
type TMathFn = Reference to Function(A, B: Integer): Integer;
var fn: TMathFn;
And as I've been developing in Delphi from 1994 until 2010 I'm a bit unfamiliar with this "Reference to" part. Still, both options seem to work identically. So...
Are they identical?
"REFERENCE TO" is to allow Anonymous Methods (inline definitions of PROCEDUREs/FUNCTIONs), which can Capture a context (for example local variables, which are captured as references, ie. if you change the variable after capture, it's the modified value that is captured, see below).
TYPE TMyProc = REFERENCE TO PROCEDURE(CONST S : STRING);
PROCEDURE Information(CONST S : STRING);
BEGIN
MessageDlg(S,mtInformation,[mbOK],0)
END;
PROCEDURE RunProc(P : TMyProc ; CONST S : STRING);
BEGIN
P(S)
END;
PROCEDURE A(B,C : INTEGER);
VAR
D : INTEGER;
P : TMyProc;
BEGIN
D:=3;
// D is 3 at the time of capture
P:=PROCEDURE(CONST S : STRING)
BEGIN
Information(S+': '+IntToStr(D)+' -> '+IntToStr(B))
END;
// D is now 4 - and is reflected in the captured routine, as
// the capture is done by REFERENCE and not by VALUE.
INC(D);
RunProc(P,'Hello')
END;
BEGIN
A(2,3)
END.
Will show "Hello: 4 -> 2" in a message box.
The above definition of P "captures" (includes) the variables D and B so that even if you pass it to another function, where these variables don't exist, you can still access them.
This would be (nearly) impossible to do with ordinary PROCEDURE [OF OBJECT] types, as they can't access local variables declared at the point of execution.
No, they are not identical.
The difference is that
TMathFn = function(A, B: Integer): Integer;
is an ordinary function,
TMathMethod = function(A, B: Integer): Integer of object;
is a method, and
TMathAnonMethod = reference to function(A, B: Integer): Integer;
is an anonymous method, but you can also assign an ordinary function or a method to a variable of this type.
So, for instance, if
type
TMathFn = function(A, B: Integer): Integer;
TMathMethod = function(A, B: Integer): Integer of object;
TMathAnonMethod = reference to function(A, B: Integer): Integer;
function Test(A, B: Integer): Integer;
begin
Result := A + B;
end;
type
TTestClass = class
function Test(A, B: Integer): Integer;
end;
{ TTestClass }
function TTestClass.Test(A, B: Integer): Integer;
begin
Result := A + B;
end;
then the following applies:
procedure TForm1.FormCreate(Sender: TObject);
var
T: TTestClass;
F: TMathFn;
M: TMathMethod;
AM: TMathAnonMethod;
begin
T := TTestClass.Create;
try
F := Test; // compiles
F := T.Test; // doesn't compile
F := function(A, B: Integer): Integer
begin
Result := A + B;
end; // doesn't compile
M := Test; // doesn't compile
M := T.Test; // compiles
M := function(A, B: Integer): Integer
begin
Result := A + B;
end; // doesn't compile
AM := Test; // compiles
AM := T.Test; // compiles
AM := function(A, B: Integer): Integer
begin
Result := A + B;
end; // compiles
finally
T.Free;
end;
end;
Under the hood, as you probably already know, F is simply a (function) pointer and M is a method pointer. Anonymous methods, on the other hand, have a more involved interface-based implementation, which allows all their magic (like variable capture).
I'm looking for a simple way of taking lines of hexadecimal data from a TStringList (always "Windows-1252" text files) and chopping them into record blocks (every line can be different length).
In Delphi 7 I used:
procedure DecodeLineAddr(const aLine: AnsiString; var ByteCount: integer; var Address:Cardinal; var RecType: Integer);
begin
//123 4567 89 0
//:10 4640 00 0000 0600 0200 fa00 004f 7800 1e00 fb00 88
ByteCount:= StrToInt('$' + copy(aLine, 2, 2));
Address := StrToInt('$' + copy(aLine, 4, 4));
RecType := StrToInt('$' + copy(aLine, 8, 2));
end;
That is, just copy the chars from the correct positions in the initial "block info" in the line, then prepend a '$' so StrToInt would interpret the string as hex.
I process line-by-line - so it's easy enough to do something like:
aLineAsTBytes:= TEncoding.ASCII.GetBytes(aStringLst[ndx]);
Then pass aLineAsTBytes into DecodeLineAddr as TBytes instead of AnsiString.
It isn't clear to me of how I should decode the various bytes (or how to carve them up appropriately) in order to return the correct results with code that will work on desktop and mobile.
That is, if using aLine:TBytes (instead of AnsiString), what's the equivalent of:
ByteCount:= StrToInt('$' + copy(aLine, 2, 2));
(and is there a better/faster way of handling this?)
TIA.
EdB
What you're already doing will work but you'll need to make a few tweaks. Most Importantly, make your function into a "string" type instead of an "AnsiString" type, which means that you'll have to convert it.
Mobile strings are 0-based, so on mobile you'll need to subtract 1 from your indexes. Or you can use my ocopy() or zcopy() functions which both perform the same on all platforms. Use ocopy() if you're dealing with old windows code, it will treat your 0-based strings as 1-based strings essentially, making it easier to port.
const
{$IFNDEF MSWINDOWS}
STRZ = 1;
{$ELSE}
STRZ = 0;
function zcopy(sString: string; iStartZeroBased: nativeint; iLength: nativeint): string;
begin
result := '';
setlength(result, lesserof(iLength, length(sString)-iStartZerobased));
movemem32(#result[strz], #sString[(strz+iStartZeroBased)], length(result)*sizeof(char));
end;
function ocopy(sString: string; iStartOneBased: nativeint; iLength: nativeint): string;
begin
result := zcopy(sString, iStartOneBased-1, iLength);
end;
Next, take this code which isn't a totally complete solution, but will give you most of your ansi-string support on mobile (with some slight caveats around pointers). But basically you can essentially convert strings by simply assigning an ansistring to a string type or vice verse. I had to hack this away from a couple of dependencies so I don't guarantee that it will compile out of the box, but it should be pretty close.
unit iosbytestring;
interface
uses
sysutils, classes;
{$IFNDEF MSWINDOWS}
const STRZERO = 0;
{$ELSE}
const STRZERO = 1;
{$ENDIF}
type
Tiosansichar = packed record
private
b: byte;
class function AnsiFromChar(c: char): byte;static;
class function CharFromAnsi(b: byte): char;static;
public
function ToChar: char;
function ToOrd: byte;
class operator Implicit(const s: Tiosansichar): string;
class operator Implicit(const s: Tiosansichar): char;
class operator Implicit(const s: Tiosansichar): byte;
class operator Implicit(const s: Tiosansichar): pointer;
end;
Tiosbytestring = record
private
Fbytes: TBytes;
function GetChar(idx: nativeint): char;
procedure SetChar(idx: nativeint; const Value: char);
function GetAddrOf(idx: nativeint): pbyte;
function getbyte(idx: nativeint): byte;
procedure setbyte(idx: nativeint; const Value: byte);
public
property chars[idx: nativeint]: char read GetChar write SetChar;
property bytes[idx: nativeint]: byte read getbyte write setbyte;
property addrof[idx: nativeint]: pbyte read GetAddrOf;
class operator Implicit(const s: TIOSByteString): string;
class operator Implicit(const s: string): TIOSByteString;
class operator Add(const s1,s2: TIOSByteString): TIOSByteSTring;
class operator Add(const s1: string; const s2: TIOSByteString): TIOSByteSTring;
class operator Add(const s1: TIOSByteString; const s2: string): TIOSByteSTring;
procedure FromString(s: string);
function ToString: string;
procedure SetLength(i: nativeint);
end;
TIOSAnsiString = TIOSByteString;
{$IFNDEF MSWINDOWS}
ansistring = TIOSByteString;
utf8string = TIOSByteString;
widestring = string;
{$ENDIF}
implementation
{ iosbytestring }
class operator Tiosbytestring.Add(const s1: string;
const s2: TIOSByteString): TIOSByteSTring;
var
ss2,ss3: string;
begin
ss2 := s2.ToString;
ss3 := s1+ss2;
result.FromString(ss3);
end;
class operator Tiosbytestring.Add(const s1: TIOSByteString;
const s2: string): TIOSByteSTring;
var
ss1,ss3: string;
begin
ss1 := s1.ToString;
ss3 := ss1+s2;
result.FromString(ss3);
end;
procedure Tiosbytestring.FromString(s: string);
begin
Fbytes := TEncoding.ANSI.GetBytes(s);
end;
function Tiosbytestring.GetAddrOf(idx: nativeint): pbyte;
begin
result := #Fbytes[idx];
end;
function Tiosbytestring.getbyte(idx: nativeint): byte;
begin
result := Fbytes[idx-strzero];
end;
function Tiosbytestring.GetChar(idx: nativeint): char;
begin
result := Tiosansichar.CharFromAnsi(Fbytes[idx-strzero]);
end;
class operator Tiosbytestring.Implicit(const s: TIOSByteString): string;
begin
result := s.ToString;
end;
class operator Tiosbytestring.Implicit(const s: string): TIOSByteString;
begin
result.FromString(s);
end;
procedure Tiosbytestring.setbyte(idx: nativeint; const Value: byte);
begin
Fbytes[idx-strzero] := value;
end;
class operator Tiosbytestring.Add(const s1,
s2: TIOSByteString): TIOSByteSTring;
var
ss1,ss2,ss3: string;
begin
ss1 := s1.ToString;
ss2 := s2.ToString;
ss3 := ss1+ss2;
result.FromString(ss3);
end;
procedure Tiosbytestring.SetChar(idx: nativeint; const Value: char);
begin
Fbytes[idx-strzero] := Tiosansichar.AnsiFromChar(value);
end;
procedure Tiosbytestring.SetLength(i: nativeint);
begin
system.setlength(Fbytes,i);
end;
function Tiosbytestring.ToString: string;
begin
result := TEncoding.ANSI.GetString(Fbytes);
end;
{ Tiosansichar }
class function Tiosansichar.AnsiFromChar(c: char): byte;
var
s: string;
te: TEncoding;
b: TBytes;
begin
s := c;
b := TEncoding.ANSI.GetBytes(c);
result := b[0];
end;
class function Tiosansichar.CharFromAnsi(b: byte): char;
var
s: string;
bytes: TBytes;
begin
system.setlength(bytes, 1);
bytes[0] := b;
s := TEncoding.ANSI.GetString(bytes, 0, 1);
result := s[low(s)];
end;
class operator Tiosansichar.Implicit(const s: Tiosansichar): char;
begin
result := s.ToChar;
end;
class operator Tiosansichar.Implicit(const s: Tiosansichar): string;
begin
result := s.ToChar;
end;
class operator Tiosansichar.Implicit(const s: Tiosansichar): pointer;
begin
result := #s.b;
end;
class operator Tiosansichar.Implicit(const s: Tiosansichar): byte;
begin
result := s.b;
end;
function Tiosansichar.ToChar: char;
begin
result := CharFromAnsi(b);
end;
function Tiosansichar.ToOrd: byte;
begin
result := b;
end;
end.
So just add the above unit, add it to your uses clause, and magically, you'll have an ansistring type on your mobile platforms. Continue using the standard ansistring type on windows.
If all is well... this is how your code snippet might end up looking.
procedure DecodeLineAddr(const aLine: AnsiString; var ByteCount: integer; var Address:Cardinal; var RecType: Integer);
var
aLineWide: string;
begin
aLineWide = aLine;
//123 4567 89 0
//:10 4640 00 0000 0600 0200 fa00 004f 7800 1e00 fb00 88
ByteCount:= StrToInt('$' + ocopy(aLineWide, 2, 2));
Address := StrToInt('$' + ocopy(aLineWide, 4, 4));
RecType := StrToInt('$' + ocopy(aLineWide, 8, 2));
end;
When I use TObjectDictionary, where TKey is object, my application work uncorrectly.
I have two units, thats contain two classes. First unit:
unit RubTerm;
interface
type
TRubTerm = Class(TObject)
private
FRubricName: String;
FTermName: String;
public
property RubricName: String read FRubricName;
property TermName: String read FTermName;
constructor Create(ARubricName, ATermName: String);
end;
implementation
constructor TRubTerm.Create(ARubricName, ATermName: String);
begin
Self.FRubricName := ARubricName;
Self.FTermName := ATermName;
end;
end;
And second unit:
unit ClassificationMatrix;
interface
uses
System.Generics.Collections, System.Generics.Defaults, System.SysUtils, RubTerm;
type
TClassificationMatrix = class(TObject)
private
FTable: TObjectDictionary<TRubTerm, Integer>;
public
constructor Create;
procedure TClassificationMatrix.AddCount(ADocsCount: Integer; ARubName, ATermName: String);
function TClassificationMatrix.GetCount(ARubName, ATermName: String): Integer;
end;
implementation
constructor TClassificationMatrix.Create;
begin
FTable := TObjectDictionary<TRubTerm, Integer>.Create;
end;
procedure TClassificationMatrix.AddCount(ADocsCount: Integer; ARubName, ATermName: String);
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
FTable.Add(ARubTerm, ADocsCount);
end;
function TClassificationMatrix.GetCount(ARubName, ATermName: String): Integer;
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
FTable.TryGetValue(ARubTerm, Result);
end;
end;
But this fragment of code work unnormal:
procedure TestTClassificationMatrix.TestGetCount;
var
DocsCountTest: Integer;
begin
FClassificationMatrix.AddCount(10, 'R', 'T');
DocsCountTest := FClassificationMatrix.GetCount('R', 'T');
end;
// DocsCountTest = 0! Why not 10? Where is problem?
Thanks!
The fundamental issue here is that the default equality comparer for your type does not behave the way you want it to. You want equality to mean value equality, but the default comparison gives reference equality.
The very fact that you are hoping for value equality is a strong indication that you should be using a value type rather than a reference type. And that's the first change that I would suggest.
type
TRubTerm = record
RubricName: string;
TermName: string;
class function New(const RubricName, TermName: string): TRubTerm; static;
class operator Equal(const A, B: TRubTerm): Boolean;
class operator NotEqual(const A, B: TRubTerm): Boolean;
end;
class function TRubTerm.New(const RubricName, TermName: string): TRubTerm;
begin
Result.RubricName := RubricName;
Result.TermName := TermName;
end;
class operator TRubTerm.Equal(const A, B: TRubTerm): Boolean;
begin
Result := (A.RubricName=B.RubricName) and (A.TermName=B.TermName);
end;
class operator TRubTerm.NotEqual(const A, B: TRubTerm): Boolean;
begin
Result := not (A=B);
end;
I've added TRubTerm.New as a helper method to make it easy to initialize new instances of the record. And for convenience, you may also find it useful to overload the equality and inequality operators, as I have done above.
Once you switch to a value type, then you would also change the dictionary to match. Use TDictionary<TRubTerm, Integer> instead of TObjectDictionary<TRubTerm, Integer>. Switching to a value type will also have the benefit of fixing all the memory leaks in your existing code. Your existing code creates objects but never destroys them.
This gets you part way home, but you still need to define an equality comparer for your dictionary. The default comparer for a record will be based on reference equality since strings, despite behaving as value types, are stored as references.
To make a suitable equality comparer you need to implement the following comparison functions, where T is replaced by TRubTerm:
TEqualityComparison<T> = reference to function(const Left, Right: T): Boolean;
THasher<T> = reference to function(const Value: T): Integer;
I'd implement these as static class methods of the record.
type
TRubTerm = record
RubricName: string;
TermName: string;
class function New(const RubricName, TermName: string): TRubTerm; static;
class function EqualityComparison(const Left,
Right: TRubTerm): Boolean; static;
class function Hasher(const Value: TRubTerm): Integer; static;
class operator Equal(const A, B: TRubTerm): Boolean;
class operator NotEqual(const A, B: TRubTerm): Boolean;
end;
Implementing EqualityComparison is easy enough:
class function TRubTerm.EqualityComparison(const Left, Right: TRubTerm): Boolean;
begin
Result := Left=Right;
end;
But the hasher requires a little more thought. You need to hash each field individually and then combine the hashes. For reference:
Quick and Simple Hash Code Combinations
What is the canonical way to write a hasher function for TEqualityComparer.Construct?
The code looks like this:
{$IFOPT Q+}
{$DEFINE OverflowChecksEnabled}
{$Q-}
{$ENDIF}
function CombinedHash(const Values: array of Integer): Integer;
var
Value: Integer;
begin
Result := 17;
for Value in Values do begin
Result := Result*37 + Value;
end;
end;
{$IFDEF OverflowChecksEnabled}
{$Q+}
{$ENDIF}
function GetHashCodeString(const Value: string): Integer;
begin
Result := BobJenkinsHash(PChar(Value)^, SizeOf(Char) * Length(Value), 0);
end;
class function TRubTerm.Hasher(const Value: TRubTerm): Integer;
begin
Result := CombinedHash([GetHashCodeString(Value.RubricName),
GetHashCodeString(Value.TermName)]);
end;
Finally, when you instantiate your dictionary, you need to provide an IEqualityComparison<TRubTerm>. Instantiate your dictionary like this:
Dict := TDictionary<TRubTerm,Integer>.Create(
TEqualityComparer<TRubTerm>.Construct(
TRubTerm.EqualityComparison,
TRubTerm.Hasher
)
);
A Dictionary depends on a key value. You are storing a reference to an object in the key. If you create two objects that are setup identically the have different values and hence different keys.
var
ARubTerm1: TRubTerm;
ARubTerm2: TRubTerm;
begin
ARubTerm1 := TRubTerm.Create('1', '1');
ARubTerm2 := TRubTerm.Create('1', '1');
// ARubTerm1 = ARubTerm2 is not possible here as ARubTerm1 points to a different address than ARubTerm2
end;
Instead you could uses a String as the First Type Parameter in the TObjectDictonary that is based on RubricName and TermName. With this you would then get back the same value.
It should also be noted, that above code in XE2 creates two memory leaks. Every object created must be freed. Hence this section of code also is leaking memory
function TClassificationMatrix.GetCount(ARubName, ATermName: String): Integer;
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
FTable.TryGetValue(ARubTerm, Result);
end;
Given all of that. If you want to use an Object as a Key you can do it with a Custom Equality Comparer. Here is your example changed to implement IEqualityComparer<T>, and fix a few memory leaks.
unit ClassificationMatrix;
interface
uses
Generics.Collections, Generics.Defaults, SysUtils, RubTerm;
type
TClassificationMatrix = class(TObject)
private
FTable: TObjectDictionary<TRubTerm, Integer>;
public
constructor Create;
procedure AddCount(ADocsCount: Integer; ARubName, ATermName: String);
function GetCount(ARubName, ATermName: String): Integer;
end;
implementation
constructor TClassificationMatrix.Create;
var
Comparer : IEqualityComparer<RubTerm.TRubTerm>;
begin
Comparer := TRubTermComparer.Create;
FTable := TObjectDictionary<TRubTerm, Integer>.Create([doOwnsKeys],TRubTermComparer.Create);
end;
procedure TClassificationMatrix.AddCount(ADocsCount: Integer; ARubName, ATermName: String);
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
FTable.Add(ARubTerm, ADocsCount);
end;
function TClassificationMatrix.GetCount(ARubName, ATermName: String): Integer;
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
try
if Not FTable.TryGetValue(ARubTerm, Result) then
result := 0;
finally
ARubTerm.Free;
end;
end;
end.
And the RubTerm.pas unit
unit RubTerm;
interface
uses Generics.Defaults;
type
TRubTerm = Class(TObject)
private
FRubricName: String;
FTermName: String;
public
property RubricName: String read FRubricName;
property TermName: String read FTermName;
constructor Create(ARubricName, ATermName: String);
function GetHashCode: Integer; override;
end;
TRubTermComparer = class(TInterfacedObject, IEqualityComparer<TRubTerm>)
public
function Equals(const Left, Right: TRubTerm): Boolean;
function GetHashCode(const Value: TRubTerm): Integer;
end;
implementation
constructor TRubTerm.Create(ARubricName, ATermName: String);
begin
Self.FRubricName := ARubricName;
Self.FTermName := ATermName;
end;
{ TRubTermComparer }
function TRubTermComparer.Equals(const Left, Right: TRubTerm): Boolean;
begin
result := (Left.RubricName = Right.RubricName) and (Left.TermName = Right.TermName);
end;
function TRubTermComparer.GetHashCode(const Value: TRubTerm): Integer;
begin
result := Value.GetHashCode;
end;
//The Hashing code was taken from David's Answer to make this a complete answer.
{$IFOPT Q+}
{$DEFINE OverflowChecksEnabled}
{$Q-}
{$ENDIF}
function CombinedHash(const Values: array of Integer): Integer;
var
Value: Integer;
begin
Result := 17;
for Value in Values do begin
Result := Result*37 + Value;
end;
end;
{$IFDEF OverflowChecksEnabled}
{$Q+}
{$ENDIF}
function GetHashCodeString(const Value: string): Integer;
begin
Result := BobJenkinsHash(PChar(Value)^, SizeOf(Char) * Length(Value), 0);
end;
function TRubTerm.GetHashCode: Integer;
begin
Result := CombinedHash([GetHashCodeString(Value.RubricName),
GetHashCodeString(Value.TermName)]);
end;
end.
Is there a function in the Delphi standard library to search string arrays for a particular value?
e.g.
someArray:=TArray<string>.Create('One','Two','Three');
if ArrayContains(someArray, 'Two') then
ShowMessage('It contains Two');
There is absolutely no need to reinvent the wheel. StrUtils.MatchStr does the job.
procedure TForm1.FormCreate(Sender: TObject);
var
someArray: TArray<string>;
begin
someArray:=TArray<string>.Create('One','Two','Three');
if MatchStr('Two', someArray) then
ShowMessage('It contains Two');
end;
Note the parameter order convention.
Another note: MatchStr is a canonicalized name assigned to this function somewhen in between Delphi 7 and Delphi 2007. Historical name is AnsiMatchStr (convention is the same as in the rest of RTL: Str/Text suffix for case-sensitivity, Ansi prefix for MBCS/Locale)
I wrote one I modeled after the old Clipper AScan function (tested in XE). #RRUZ's answer is more correct (there is one existing), but mine doesn't require the array to be sorted first and is fast enough on small arrays. (It also works in pre-generics versions of Delphi.) I also overload it for various types of array - here are the implementations for string and integer:
// Returns the 0-based index of Value if it's found in the array,
// -1 if not. (Similar to TStrings.IndexOf)
function AScan(const Ar: array of string; const Value: string): Integer; overload;
var
i: Integer;
begin
Result := -1;
for i := Low(Ar) to High(Ar) do
if SameText(Ar[i], Value) then
begin
Result := i;
Break
end;
end;
function AScan(const Ar: array of Integer; const Value: Integer): Integer; overload;
var
i: Integer;
begin
Result := -1;
for i := Low(Ar) to High(Ar) do
if (Ar[i] = Value) then
begin
Result := i;
Break
end;
end;
procedure TForm2.FormShow(Sender: TObject);
var
someStrArray: TArray<string>;
someIntArray: TArray<Integer>;
Idx: Integer;
begin
someStrArray := TArray<string>.Create('One', 'Two', 'Three');
Idx := AScan(someStrArray, 'Two');
if Idx > -1 then
ShowMessage(Format('It contains Two at index %d', [Idx]))
else
ShowMessage('Not found');
someIntArray := TArray<Integer>.Create(8, 16, 32);
Idx := AScan(someIntArray, 32);
if Idx > -1 then
ShowMessage(Format('It contains 32 at %d', [Idx]))
else
ShowMessage('16 not found');
end;
For versions of Delphi that support generics, here's a version that doesn't require the array to be sorted, and that also allows you to provide the comparison function if needed:
Interface:
type
TGenericsUtils = class
public
class function AScan<T>(const Arr: array of T; const Value: T; const Comparer: IEqualityComparer<T>): Integer; overload;
class function AScan<T>(const Arr: array of T; const Value: T): Integer; overload;
end;
Implementation
class function TGenericsUtils.AScan<T>(const Arr: array of T; const Value: T): Integer;
begin
Result := AScan<T>(Arr, Value, TEqualityComparer<T>.Default);
end;
class function TGenericsUtils.AScan<T>(const Arr: array of T; const Value: T;
const Comparer: IEqualityComparer<T>): Integer;
var
i: Integer;
begin
for i := Low(Arr) to High(Arr) do
if Comparer.Equals(Arr[i], Value) then
Exit(i);
Exit(-1);
end;
Test code:
var
AIntTest: TIntegerDynArray;
AStrTest: TStringDynArray;
begin
AIntTest := TIntegerDynArray.Create(12, 15, 6, 1, 4, 9, 5);
AStrTest := TStringDynArray.Create('One', 'Six', 'Three', 'Four', 'Twelve');
WriteLn('AIntTest contains 9 at index ', TGenericsUtils.AScan<Integer>(AIntTest, 9));
WriteLn('AStrTest contains ''Four'' at index ', TGenericsUtils.AScan<String>(AStrTest, 'Four'));
ReadLn;
end.
you can use the TArray.BinarySearch function, which is part of the Generics.Collections unit.
check this sample
{$APPTYPE CONSOLE}
{$R *.res}
uses
Generics.Defaults,
Generics.Collections,
System.SysUtils;
Var
someArray: TArray<string>;
FoundIndex : Integer;
begin
try
someArray:=TArray<string>.Create('a','b','c');
if TArray.BinarySearch<String>(someArray, 'b', FoundIndex, TStringComparer.Ordinal) then
Writeln(Format('Found in index %d',[FoundIndex]))
else
Writeln('Not Found');
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.
Note: BinarySearch requires that the array be sorted.
The following code (constructed only to demonstrate the problem) compiles and works in Delphi 2010. In Delphi 2009, compiler fails with "E2035 Not enough actual parameters".
program Project50;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TMyProc = reference to procedure(param: integer);
var
a: TProc;
b: TMyProc;
begin
b := procedure (param: integer)
begin
end;
a := TProc(b); // <-- [DCC Error] Project50.dpr(19): E2035 Not enough actual parameters
end.
I have found only one very ugly hack to work around the problem (a: TProc absolute b). Does anybody knows of a nicer workaround for this compiler deficiency?
[TProc field is actually hidden inside a record that can store various 'executable' code - TProcedure, TMethod and TProc. Casting is used to store specific anonymous proc into this field.]
The trick is not to do
a := TProc(b);
but
TMyProc(a) := b;
That compiles and works in D2009. Sample project attached below.
program Project51;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TMyProc = reference to procedure(var param: integer);
TStorage = record
FDelegate: TProc;
end;
var
a : TMyProc;
b : TMyProc;
param: integer;
stg : TStorage;
begin
b := procedure (var param: integer)
begin
param := 2*param;
end;
// stg.FDelegate := TMyProc(b); // doesn't compile in Delphi 2009, compiles in Delphi 2010
TMyProc(stg.FDelegate) := b;
param := 21;
TMyProc(stg.FDelegate)(param);
Writeln(param);
Readln;
end.
However, this doesn't work if casting to a local variable.
var
p: TProc;
a: TMyProc;
TMyProc(p) := a; // this will not compile
Curiouser and curiouser.
I have found a hack #2:
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TMyProc = reference to procedure(param: integer);
var
a: TProc;
b: TMyProc;
begin
b := procedure (param: integer)
begin
Writeln('asdf');
end;
PPointer(#a)^ := PPointer(#b)^;
a;
readln;
end.
I am in doubt what are you trying to achieve by assigning TMyProc (with param argument) to TProc (without argument)?
Updated: A hack #3 (should increment ref counter, the idea is stolen from System._IntfCopy):
procedure AnonCopy(var Dest; const Source);
var
P: Pointer;
begin
P:= Pointer(Dest);
if Pointer(Source) <> nil
then IInterface(Source)._AddRef;
Pointer(Dest):= Pointer(Source);
if P <> nil then
IInterface(P)._Release;
end;
var
a: TProc;
b: TMyProc;
begin
b := procedure (param: integer)
begin
Writeln('asdf');
end;
AnonCopy(a, b);
// PPointer(#a)^ := PPointer(#b)^;
a;
readln;
end.
It appears that the best way would be to use generics to store the correct type of delegate in the record. No hacks required.
program Project51;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TMyProc = reference to procedure(var param: integer);
TStorage<T> = record
FDelegate: T;
end;
var
a : TMyProc;
b : TMyProc;
p : TProc;
param: integer;
stg : TStorage<TMyProc>;
begin
b := procedure (var param: integer)
begin
param := 2*param;
end;
stg.FDelegate := b;
param := 21;
stg.FDelegate(param);
Writeln(param);
Readln;
end.