How to call a nested function with AsyncCalls - delphi

I have this piece of working code using AsyncCalls 2.99 in the modified version by Zarko Gajic:
function TForm1.DoIt(i:integer):integer;
begin
end;
procedure TForm1.Main;
//-------------------------------------------------------
procedure CallIt;
begin
TAsyncCalls.Invoke(
procedure
var i:integer;
begin
For i := 0 to 10 do
If i < 11
then TAsyncCalls.Invoke<integer>(DoIt,i));
end);
end;
//-------------------------------------------------------
begin
CallIt;
end;
Now I would like to move the function DoIt into Main to be a nested function next to CallIt:
procedure TForm1.Main;
//-------------------------------------------------------
function DoIt(i:integer):integer;
begin
end;
//-------------------------------------------------------
procedure CallIt;
begin
TAsyncCalls.Invoke(
procedure
var i:integer;
begin
For i := 0 to 10 do
If i < 11
then TAsyncCalls.Invoke<integer>(DoIt,i));
end);
end;
//-------------------------------------------------------
begin
CallIt;
end;
The above code (naturally) does not work. As much as I unterstand Invoke requires a method as parameter and a nested function isn't one.
Invoke expects a TAsyncCallArgGenericMethod:
class function Invoke<T>(Event: TAsyncCallArgGenericMethod<T>; const Arg: T): IAsyncCall; overload; static;
TAsyncCallArgGenericMethod<T> = function(Arg: T): Integer of object;
I have already received a hint to convert the TAsyncCallArgGenericMethod into a reference:
TAsyncCallArgGenericMethod<T> = reference to function(Arg: T): Integer;
Although I have the general notion (i.e. illusion) that I understand the concept I have not been able to produce working code.

Now I would like to move the function DoIt into Main to be a nested function next to CallIt:
You can not call nested function from outside the function containing it - because nested functions need to access the outer(containing) function local variables, that only exists while executing code inside that containing function.
Even if the particular nested function does not evaluate their rights of accessing those local variables - it has those rights and the compiler should be able to produce all the lo-level scaffolding for that.
Specifically in your snippet, You can not call TForm1.Main.DoIt from outside of the TForm1.Main itself. So you can not take the reference to it and pass it to some external body like AsyncCall dispatcher.
It does not depend upon whether you would use procedure of object or reference to procedure or any other type - it is the fundamental property of nested function that they "exist" only locally to the containing function and only can be run when the outer function runs. AsyncCall would most probably try to run the function when TForm1.Main would be exited and thus its local variables stack frame required by TForm1.Main.DoIt would not exist.
You have to find some other way to "pack" those functions together, nested functions would not do here.
For example one may try using Advanced Records here.
Try to arrange it somehow like that:
type
TForm1 = class(TForm)
....
private
type Dummy = record
procedure CallIt;
procedure DoIt(const i:integer);
end;
end;
....
//-------------------------------------------------------
procedure TForm1.Dummy.CallIt;
begin
TAsyncCalls.Invoke(
procedure
var i:integer;
begin
For i := 0 to 10 do
If i < 11
then TAsyncCalls.Invoke<integer>(DoIt,i));
end);
end;
procedure TForm1.Dummy.DoIt(const i:integer);
begin
end;
procedure TForm1.Main;
var d: Dummy;
begin
d.CallIt;
end;
Also, I think your approach is wrong here: you would instantly form many-many threads exhausting your OS resources.
I would suggest you using OmniThreadLibrary instead, where there are hi-level Parallel-Loop and Collection-Pipeline concepts. They would give you benefit of automatic threads pool management, so you would only have so many worker threads as your CPU can bear, adapting your program to any hardware it would happen to run on.

I may also have the illusion that I understand these things (i.e. I may be wrong) so take this with a pinch of salt, but this is my take on it.
A nested function has access to all parameters available to the calling function (including self), but has no 'hidden' parameters (it doesn't need any). The class function on the other hand has a hidden parameter (called 'self') that the function accesses to find the object that is actually calling the function. Thus the signatures are totally different.
If you go back to the olden days when C++ was an interpreter, something like Fred.Main( x, y) in C++ would be translated to something like Main( Fred, x, y) in C. I only include this to illustrate how that hidden parameter works.
So the upshot is you can't do what you are trying to do because by moving DoIt inside your Main function, you are completely changing its signature, and indeed how it works.

I just couldn't leave it at that since for some reason I really had sunk my teeth into it. Now, here's a solution. Not a solution I would recommend, but a solution.
There has been a discussion here on stackoverflow some 4 years ago. David quoted the documentation and continued:
If I recall correctly, an extra, hidden, parameter is passed to nested functions with the pointer to the enclosing stack frame. This is omitted in 32 bit code if no reference is made to the enclosing environment.
Sertaç Akyüz apparently poked around in the assembler code and reported:
It's an implicit parameter alright! The compiler assumes it has its thing in 'rcx' and the parameters to the function are at 'rdx' and 'r8', while in fact there's no 'its thing' and the parameters are at 'rcx' and 'rdx'.
This seemed to finish the whole thing.
But then, there is this text: How to pass a nested routine as a procedural parameter (32 bit). A rather surprising title if you consider the documentation. This led to the following code:
{unit AsyncCalls;}
TAsyncCalls = class(TObject)
private
type
…
//TAsyncCallArgGenericMethod<T> = function(Arg: T): Integer of object;
TAsyncCallArgGenericMethod<T> = reference to function(Arg: T): Integer;
uses … ,AsyncCalls,AsyncCallsHelper;
procedure TForm1.Main;
//-------------------------------------------------------
function DoIt(i:integer):integer;
begin
Result := i;
end;
//-------------------------------------------------------
procedure CallIt;
var p:Pointer;
begin
p := #DoIt;
TAsyncCalls.Invoke(
procedure
var i:integer;
begin
For i := 0 to 10 do
If i < 11 then
AsyncHelper.AddTask(TAsyncCalls.Invoke<integer>(p,i));
end);
end;
//-------------------------------------------------------
begin
CallIt;
end;
This code works. As I mentioned before, I wouldn't recommend using it, but it works. I learned a lot in the course of finding a solution which I now consider the main benefit.

Related

Using _Recordset result with TADOConnection.Execute function

TADOConnection.Execute function returns a _Recordset.
I am currently using this code for simplicity (1):
V := ADOConnection1.Execute(SQL).Fields[0].Value;
I know that the recordset is never empty so no worry about BOF.
Now I can write it like this with a local _Recordset variable (2).
var
rs: _Recordset;
rs := ADOConnection1.Execute(SQL);
V := rs.Fields[0].Value;
A bit more code.
Now my question is: since the _Recordset is an interface variable returned by Execute function, would it be correctly released if I'm not using a local rs variable (1)? is using my simplified code (1) safe and could there be a reference count issue here?
I would like to get some insights about this issue please.
EDIT: My question is specific to the case:
V := ADOConnection1.Execute(SQL).Fields[0].Value
where I do not have a local variable reference to _Recordset.
Try this: Create a procedure that contains the single line
V := AdoConnection1.Execute(Sql).Fields[0].Value;
, put a breakpoint on it run the app and view the disassembly. You'll see that just before the line
jmp #HandleFinally
there are three calls to
call #IntfClear
That's the compiler releasing the three interfaces it has had to access in order to execute the statement, namely
the RecordSet interface returned by AdoConnection1.Execute(),
the Fields interface of that RecordSet, and
the particular Field interface obtained via Fields[0].
So, it has automatically generated the code necessary to free up these interfaces after executing the source statement.
The following is an imperfect analogy but its disassembly is much easier to follow; it illustrates the code the compiler automatically generates to deal with finalizing interfaces.
Given
type
IMyInterface = interface
function GetValue : Integer;
end;
TMyClass = class(TInterfacedObject, IMyInterface)
function GetValue : Integer;
destructor Destroy; override;
end;
TForm1 = class(TForm)
[...]
procedure Button1Click(Sender: TObject);
end;
destructor TMyClass.Destroy;
begin
inherited;
end;
function TMyClass.GetValue: Integer;
begin
Result := 1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
I : IMyInterface;
begin
I := TMyClass.Create;
Caption := IntToStr(I.GetValue);
end;
the CPU disassembly of Button1Click looks like this
and the line arrowed red is where the interface is cleared despite the source code
not doing anything explicit to do this. Put a breakpoint on the
inherited
in TMyClass.Destroy and you'll find that also gets called, again despite the
source code not explicitly calling it.
Like I said, the above is an imperfect analogy. An interesting thing is that for the horrific (from the pov of the usage of the "with" construct) alternative
procedure TForm1.Button1Click(Sender: TObject);
begin
with IMyInterface(TMyClass.Create) do
Caption := IntToStr(GetValue);
end;
which uses no (explicit) local variable, the compiler generates the exact same code as the disassembly illustrated.
Of course, the situation in the q is slightly different because the memory allocated to the recordset object is on the other side of the Ado COM interface, so one has no control over whether that memory is correctly de-allocated beyond the fact that the compiler will generate the code to call _Release on the interface to it.

Is it possible to sort a TListBox using a custom sort comparator?

I need to sort my TListBox but I realized it is a lot of work to modify my code if I were to say make a TStringList, sort it and then copy those items into the Listbox. The main reason it's a lot of work is that I have many places in the code where the listbox contents are modified and I guess I would have to edit them all to force a sort at the time they are added, deleted or whatever.
I would much prefer something that let me just attach a method to a listbox somehow to sort it using my custom sort logic.
Is it somehow possible?
This is no Problem! Look at this Code:
function CompareDates(List: TStringList; Index1, Index2: Integer): Integer;
var
d1, d2: TDateTime;
begin
d1 := StrToDate(List[Index1]);
d2 := StrToDate(List[Index2]);
if d1 < d2 then
Result := -1
else if d1 > d2 then
Result := 1
else
Result := 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.Assign(ListBox1.Items);
sl.CustomSort(CompareDates);
ListBox1.Items.Assign(sl);
finally
sl.Free
end;
end;
If you are using Delphi XE or later, I have a possibility for you.
Note that I say "possibility" and not "solution" as it is more of a hack than anything else and I wouldn't really approve this in production code unless it was a last resort.
From what I understand, what you are essentially trying to achieve is override the behavior of the Add function (which is virtual) to make it insert at the right position based on a custom order. (If you need to also override insert, this works too). If it was possible to override the TStrings descendant TListbox uses, that would be simple, but we are not that lucky.
Delphi XE introduced a new class called TVirtualMethodInterceptor (Rtti unit) that allows to intercept virtual method to do whatever we want to do with it. We can inspect and modify the parameters, call other functions, or litterally cancel the call and do nothing at all.
Here's how the proof of concept I made looked like:
//type
// TCompareFunc<T1> = reference to function (const Arg1, Arg2 : T1) : Integer;
procedure TForm4.FormCreate(Sender: TObject);
var vCompareFunc : TCompareFunc<string>;
RttiContext : TRttiContext;
vAddMethod : TRttiMethod;
vRttiType : TRttiType;
begin
RttiContext := TRttiContext.Create;
vRttiType := RttiContext.GetType(TStrings);
vAddMethod := vRttiType.GetMethod('Add');
vCompareFunc := MyCompareFunc;
Fvmi := TVirtualMethodInterceptor.Create(Listbox1.Items.ClassType);
Fvmi.OnBefore := procedure(Instance: TObject; Method: TRttiMethod;
const Args: TArray<TValue>; out DoInvoke: Boolean; out Result: TValue)
var
idx : Integer;
begin
if Method = vAddMethod then
begin //if it's the Add method, map it to Insert at the right position
DoInvoke := False;
BinarySearch(TStrings(Instance), Args[0].AsString, vCompareFunc,idx);
TStrings(Instance).Insert(idx, Args[0].AsString);
end;
end;
Fvmi.Proxify(Listbox1.Items);
end;
This proof of concept intercept the call to TStrings.add and map it to binarysearch/Insert so that the items of the list are always in the right order. This does not override the Insert or Assign function, or any other function modifying the list. If you want to use this approach, you need to override all the "offending" functions.
Disclaimer : Since I have never really used this technique, don't consider this example as the golden rule for TVirtualMethodInterceptor's usage. It does work, but it might have performance implications or others that I'm unaware of.
One important point to mention (from Barry Kelly's blog, see below)
One thing the TVirtualMethodInterceptor class doesn't have, however,
is a way to unhook (unproxify) the object. If the object is never
unhooked, it's important that the object doesn't outlive the
interceptor, because the interceptor needs to allocate executable
memory in order to create the little stubs with which it redirects
method calls to the events.
If you want to dig deeper, here's a pretty good article on the subject:
http://blog.barrkel.com/2010/09/virtual-method-interception.html

Pointer to Function of (Sub-)Method?

If you like to use a method's pointer as an argument, you need to type the method as function of object like this works good:
type TAcceptor = function(filename:string):boolean of object;
function acceptor(filename:string):boolean;
begin
result := filename <> '';
end;
What if you like to use the pointer of a sub-method? It does not work:
procedure TForm1.Button1Click(Sender:TObject);
function acceptor(filename:string):boolean of object;
begin
result := filename <> '';
end;
begin
end;
The error occour: ; expected but OF found!
Question: Is there any subfunction-pointer? Can i cast it?
I don't see how that this would be possible.
http://docwiki.embarcadero.com/RADStudio/XE6/en/Procedural_Types
If you look under the method pointers section, it specifically says that nested procedures and functions cannot be used:
"Nested procedures and functions (routines declared within other
routines) cannot be used as procedural values, nor can predefined
procedures and functions."
You might be able to work around it using an anonymous method. Something like:
procedure TForm1.Button1Click(Sender:TObject);
begin
DoSomethingWithAcceptor(function(FileName: string): Boolean
begin
Result := FileName <> '';
end);
end;
CAUTION
I know that the following is not universally applicable, but it works for all known Win32 versions of Delphi. As long as you are aware of this, and check its functionality in new versions, it is a viable hack, IMO.
Passing nested functions to methods
In older code, I used this to do some "poor man's anonymous methods":
type
TLocal = packed record
Code: Pointer; // local (nested) function
Frame: Pointer; // outer stack frame for local function
end;
To fill such a local inside a method, I wrote the function Local:
function Local(LocalFunction: Pointer): TLocal;
asm
MOV [EDX].TLocal.Frame,EBP
MOV [EDX].TLocal.Code,EAX
end;
Inside my unit (some kind of generic collection), I wrote a function to call them, passing one parameter (of type TGeneric, in this case, which is not important here, you can also pass a pointer or some such).
// Calls local function using local closure provided, passing
// T as parameter to the local.
function CallLocal(T: TGeneric; const Local: TLocal): TGeneric;
asm
PUSH [EDX].TLocal.Frame
CALL [EDX].TLocal.Code
ADD ESP,4
end;
It was used like this:
function TStdCollection.AsArray: TGenericArray;
var
I: Integer;
A: TGenericArray;
procedure ToArray(E: TGeneric);
begin
Result[I] := E.Traits.Copy(E);
Inc(I);
end;
begin
SetLength(A, Count);
I := 0;
ForEach(Local(#ToArray));
Assert(I = Count);
Result := A;
end;
The code in the nested function makes a copy of the element and stores it in the array. The main procedure then passes the nested function ToArray (together with its stack frame) as parameter to ForEach, which is implemented this way:
function TStdCollection.ForEach(Operation: TLocal): ICollection;
var
Enum: IEnumerator;
Elem: TGeneric;
begin
Enum := GetEnumerator;
Elem := Enum.First;
while Elem <> nil do
begin
CallLocal(Elem, Operation);
Elem := Enum.Next;
end;
Result := Self;
end;
These examples show how to use the Locals. I hope this more or less answers your question.
Note
Note that this code was written in the Delphi 6 timeframe. I know there are better alternatives these days, like generics and anonymous methods. But if compatibility with Delphi 7 is required, the above might be a solution.

Delphi - procedure fails to complete, but works fine with "showmessage" between.?

I'm not quite sure how to even ask this question, since I don't know whether it is related to the execution time, application process.message procedure or anything else.
I'm having (for me) weird situations, where the procedure fails to run and raises system exception on run, while it runs completely flawless if I put "showmessage" there in between (which I put so that I could quickly see what's going on in between. I prefer that way over watches somehow...).
I'm not sure whether the code matters or not, but I'll give it below:
procedure LoadSettings;
var SettingsBuffToLoad: TStringList;
begin
SettingsBuffToLoad:=TStringList.Create;
Encoding:=TEncoding.ANSI;
SettingsBuffToLoad.LoadFromFile('bin/settings.txt', Encoding);
// showmessage(settingsbufftoload.Strings[0]);
SettingsBuffer:=Decode(SettingsBuffToLoad);
// showmessage(settingsbuffer.Strings[0]); //decode
end;
The Decode procedure is declared as external and is read from the dll.
If I just remove those "/" , so that it becomes the code instead of comment, it works just fine. However, set as you see now, it raises exception, but after the procedure is already done. (the debugger last break point is stopped at "end;", after continuing however it raises exception instead of showing the form; this procedure is called as the last thing in FormCreate procedure.
Is there anything that has to do with the timing, which ShowMessage solves, or...? :/
Update:
The decode functions, as asked:
this is how it's declared, right above of the implementation and variables of the form:
function Decode(Buff: TStringList): TStringList; StdCall; external 'bin\settings.txt';
And this is in the dll:
function Decode(Buff: TStringList): TStringList; export;
var
t, u, h: integer;
s: String;
begin
DecodeBuffer.Clear;
DecodeBuffer:=Buff;
for h := 0 to DecodeBuffer.Count-1 do
begin
s := DecodeBuffer.Strings[h];
t := Length(s);
if t > 0 then
begin
for u := 0 to t-1 do
begin
s[u+1] := DecodeChar(s[u+1], (h mod 5) + 1);
end;
DecodeBuffer.Strings[h] := s;
end;
end;
Result:=DecodeBuffer;
end;
This code was discussed in a question at Delphi changing Chars in string - missunderstood behavior - XE3 and is used from Remy's answer. The DecodeChar is, I believe simply unimportant here, or is it?
Also, the same goes with the function to save settings, which is called at FormClose event:
This is:
procedure TScribbles.SaveSettings;
var SettingsBuffToSave: TStringList;
begin
SettingsBuffToSave:=TStringList.Create;
Encoding := TEncoding.ANSI;
// Showmessage(settingsbuffer.Strings[0]);
SettingsBuffToSave:=Encode(SettingsBuffer);
// Showmessage(settingsbufftosave.Strings[0]);
SettingsBuffToSave.SaveToFile('bin/settings.txt', Encoding);
end;
With the first ShowMessage used as code instead of comment, it works, while otherwise in a comment function as it is written above, it calls external exception the same way as on Decode.
Is it possible, that the SettingsBuffToSave is just not yet created when it already calls the function Encode, or what?
At that time, the SettingsBuffer exists and is populated, so it really seems weird that it raises errors, which disappears with simply putting ShowMessage in there.
(Function Encode is basically a mirror of Decode, so the code is not important here...)
This code is VERY VERY VERY dangerous on many levels. Using objects across the DLL boundary in an unsafe manner. Mismanagement of object pointers across function calls. You need a redesign. Try the following as a start:
procedure Decode(Buff: PChar; BuffLen: Integer; ListIndex: Integer); stdcall; export;
var
u: integer;
begin
for u := 0 to BuffLen-1 do
begin
Buff^ := DecodeChar(Buff^, (ListIndex mod 5) + 1);
Inc(Buff);
end;
end;
procedure Encode(Buff: PChar; BuffLen: Integer; ListIndex: Integer); stdcall; export;
var
u: integer;
begin
for u := 0 to BuffLen-1 do
begin
Buff^ := EncodeChar(Buff^, (ListIndex mod 5) + 1);
Inc(Buff);
end;
end;
procedure Decode(Buff: PChar; BuffLen: Integer; ListIndex: Integer); stdcall; external '...';
procedure Encode(Buff: PChar; BuffLen: Integer; ListIndex: Integer); stdcall; external '...';
procedure LoadSettings;
var
h: Integer;
begin
SettingsBuffer := TStringList.Create;
SettingsBuffer.LoadFromFile('bin/settings.txt', TEncoding.ANSI);
for h := 0 to SettingsBuff.Count-1 do
begin
Decode(PChar(SettingsBuff[h]), Length(SettingsBuff[h]), h);
end;
end;
procedure TScribbles.SaveSettings;
var
h: Integer;
begin
for h := 0 to SettingsBuff.Count-1 do
begin
Encode(PChar(SettingsBuff[h]), Length(SettingsBuff[h]), h);
end;
SettingsBuff.SaveToFile('bin/setpb95enc.dll', TEncoding.ANSI);
end;
The obvious problem here is that the code exists in a DLL. Most likely you didn't arrange for the DLL to share its host's heap. And a Delphi class cannot be passed across a DLL boundary.
If you want to share Delphi classes between modules, you must use packages. Of course, another option is to put all the code in the same module. That is remove the DLL, and compile everything in the executable. The final option is to use valid interop types for DLLs.
Of course, there could be other reasons for the actual error. The code smells bad. For instance, what is this:
DecodeBuffer:=Buff;
Is DecodeBuffer a global variable? If so then it is plausible that you refer to the object after it has been destroyed. Not that I can see evidence of anything being destroyed. Without wishing to seem rude, your code looks like it may have multiple problems. As a matter of urgency you need to:
Deal with the DLL problem described above.
Remove global variables.
Fix lifetime issues. Stop leaking.
Enable range checking to locate buffer overruns.
Add FastMM in debug mode to try to catch heap corruptions.
I think I know what's going on here: I think your stack is getting smashed.
Furthermore, I rather suspect the actual cause is the Decode procedure using an uninitialized variable. Your ShowMessage statement (it would be the first one that matters if I'm right) changes what's on the stack and thus changes the uninitialized variable.
If I'm right this is going to have some heisenbug attributes--anything you do to find out what's going on will change the value of the uninitialized variable.
One thing to try: Declare a large local variable (the idea is to use up stack space) and make sure it's not discarded by the compiler. This will move things in memory and thus likely defuse the blowup. If it works it's pretty conclusive at to what's going on.

With a class operator is an implicit typecast to itself allowed?

I have a record that looks like:
TBigint = record
PtrDigits: Pointer; <-- The data is somewhere else.
Size: Byte;
MSB: Byte;
Sign: Shortint;
...
class operator Implicit(a: TBigint): TBigint; <<-- is this allowed?
....
The code is pre-class operator legacy code, but I want to add operators.
I know the data should really be stored in a dynamic array of byte, but I do not want to change the code, because all the meat is in x86-assembly.
I want to following code to trigger the class operator at the bottom:
procedure test(a: TBignum);
var b: TBignum;
begin
b:= a; <<-- naive copy will tangle up the `PtrDigit` pointers.
....
If I add the implicit typecast to itself, will the following code be executed?
class operator TBigint.Implicit(a: TBigint): TBigint;
begin
sdpBigint.CreateBigint(Result, a.Size);
sdpBigint.CopyBigint(a, Result);
end;
(Will test and add the answer if it works as I expect).
My first answer attempts to dissuade against the idea of overriding the assignment operator. I still stand by that answer, because many of the problems to be encountered are better solved with objects.
However, David quite rightly pointed out that TBigInt is implemented as a record to leverage operator overloads. I.e. a := b + c;. This is a very good reason to stick with a record based implementation.
Hence, I propose this alternative solution that kills two birds with one stone:
It removes the memory management risks explained in my other answer.
And provides a simple mechanism to implement Copy-on-Write semantics.
(I do still recommend that unless there's a very good reason to retain a record based solution, consider switching to an object based solution.)
The general idea is as follows:
Define an interface to represent the BigInt data. (This can initially be minimalist and support only control of the pointer - as in my example. This would make the initial conversion of existing code easier.)
Define an implementation of the above interface which will be used by the TBigInt record.
The interface solves the first problem, because interfaces are a managed type; and Delphi will dereference the interface when a record goes out of scope. Hence, the underlying object will destroy itself when no longer needed.
The interface also provides the opportunity to solve the second problem, because we can check the RefCount to know whether we should Copy-On-Write.
Note that long term it might prove beneficial to move some of the BigInt implementation from the record to the class & interface.
The following code is trimmed-down "big int" implementation purely to illustrate the concepts. (I.e. The "big" integer is limited to a regular 32-bit number, and only addition has been implemented.)
type
IBigInt = interface
['{1628BA6F-FA21-41B5-81C7-71C336B80A6B}']
function GetData: Pointer;
function GetSize: Integer;
procedure Realloc(ASize: Integer);
function RefCount: Integer;
end;
type
TBigIntImpl = class(TInterfacedObject, IBigInt)
private
FData: Pointer;
FSize: Integer;
protected
{IBigInt}
function GetData: Pointer;
function GetSize: Integer;
procedure Realloc(ASize: Integer);
function RefCount: Integer;
public
constructor CreateCopy(ASource: IBigInt);
destructor Destroy; override;
end;
type
TBigInt = record
PtrDigits: IBigInt;
constructor CreateFromInt(AValue: Integer);
class operator Implicit(AValue: TBigInt): Integer;
class operator Add(AValue1, AValue2: TBigInt): TBigInt;
procedure Add(AValue: Integer);
strict private
procedure CopyOnWriteSharedData;
end;
{ TBigIntImpl }
constructor TBigIntImpl.CreateCopy(ASource: IBigInt);
begin
Realloc(ASource.GetSize);
Move(ASource.GetData^, FData^, FSize);
end;
destructor TBigIntImpl.Destroy;
begin
FreeMem(FData);
inherited;
end;
function TBigIntImpl.GetData: Pointer;
begin
Result := FData;
end;
function TBigIntImpl.GetSize: Integer;
begin
Result := FSize;
end;
procedure TBigIntImpl.Realloc(ASize: Integer);
begin
ReallocMem(FData, ASize);
FSize := ASize;
end;
function TBigIntImpl.RefCount: Integer;
begin
Result := FRefCount;
end;
{ TBigInt }
class operator TBigInt.Add(AValue1, AValue2: TBigInt): TBigInt;
var
LSum: Integer;
begin
LSum := Integer(AValue1) + Integer(AValue2);
Result.CreateFromInt(LSum);
end;
procedure TBigInt.Add(AValue: Integer);
begin
CopyOnWriteSharedData;
PInteger(PtrDigits.GetData)^ := PInteger(PtrDigits.GetData)^ + AValue;
end;
procedure TBigInt.CopyOnWriteSharedData;
begin
if PtrDigits.RefCount > 1 then
begin
PtrDigits := TBigIntImpl.CreateCopy(PtrDigits);
end;
end;
constructor TBigInt.CreateFromInt(AValue: Integer);
begin
PtrDigits := TBigIntImpl.Create;
PtrDigits.Realloc(SizeOf(Integer));
PInteger(PtrDigits.GetData)^ := AValue;
end;
class operator TBigInt.Implicit(AValue: TBigInt): Integer;
begin
Result := PInteger(AValue.PtrDigits.GetData)^;
end;
The following tests were written as I built up the proposed solution. They prove: some basic functionality, that the copy-on-write works as expected, and that there are no memory leaks.
procedure TTestCopyOnWrite.TestCreateFromInt;
var
LBigInt: TBigInt;
begin
LBigInt.CreateFromInt(123);
CheckEquals(123, LBigInt);
//Dispose(PInteger(LBigInt.PtrDigits)); //I only needed this until I
//started using the interface
end;
procedure TTestCopyOnWrite.TestAssignment;
var
LValue1: TBigInt;
LValue2: TBigInt;
begin
LValue1.CreateFromInt(123);
LValue2 := LValue1;
CheckEquals(123, LValue2);
end;
procedure TTestCopyOnWrite.TestAddMethod;
var
LValue1: TBigInt;
begin
LValue1.CreateFromInt(123);
LValue1.Add(111);
CheckEquals(234, LValue1);
end;
procedure TTestCopyOnWrite.TestOperatorAdd;
var
LValue1: TBigInt;
LValue2: TBigInt;
LActualResult: TBigInt;
begin
LValue1.CreateFromInt(123);
LValue2.CreateFromInt(111);
LActualResult := LValue1 + LValue2;
CheckEquals(234, LActualResult);
end;
procedure TTestCopyOnWrite.TestCopyOnWrite;
var
LValue1: TBigInt;
LValue2: TBigInt;
begin
LValue1.CreateFromInt(123);
LValue2 := LValue1;
LValue1.Add(111); { If CopyOnWrite, then LValue2 should not change }
CheckEquals(234, LValue1);
CheckEquals(123, LValue2);
end;
Edit
Added a test demonstrating use of TBigInt as value parameter to a procedure.
procedure TTestCopyOnWrite.TestValueParameter;
procedure CheckValueParameter(ABigInt: TBigInt);
begin
CheckEquals(2, ABigInt.PtrDigits.RefCount);
CheckEquals(123, ABigInt);
ABigInt.Add(111);
CheckEquals(234, ABigInt);
CheckEquals(1, ABigInt.PtrDigits.RefCount);
end;
var
LValue: TBigInt;
begin
LValue.CreateFromInt(123);
CheckValueParameter(LValue);
end;
There is nothing in Delphi that allows you to hook into the assignment process. Delphi has nothing like C++ copy constructors.
Your requirements, are that:
You need a reference to the data, since it is of variable length.
You also have a need for value semantics.
The only types that meet both of those requirements are the native Delphi string types. They are implemented as a reference. But the copy-on-write behaviour that they have gives them value semantics. Since you want an array of bytes, AnsiString is the string type that meets your needs.
Another option would be to simply make your type be immutable. That would let you stop worrying about copying references since the referenced data could never be modified.
It seems to me your TBigInt should be a class rather than a record. Because you're concerned about PtrDigits being tangled up, it sounds like you're needing extra memory management for what the pointer references. Since records don't support destructors there's no automatic management of that memory. Also if you simply declare a variable of TBigInt, but don't call the CreatBigInt constructor, the memory is not correctly initialised. Again, this is because you cannot override a record's default parameterless constructor.
Basically you have to always remember what has been allocated for the record and remember to manually deallocate. Sure you can have a deallocate procedure on the record to help in this regard, but you still have to remember to call it in the correct places.
However that said, you could implement an explicit Copy function, and add an item to your code-review checklist that TBitInt has been copied correctly. Unfortunately you'll have to be very careful with the implied copies such as passing the record via a value parameter to another routine.
The following code illustrates an example conceptually similar to your needs and demonstrates how the CreateCopy function "untangles" the pointer. It also highlights some of the memory management problems that crop up, which is why records are probably not a good way to go.
type
TMyRec = record
A: PInteger;
function CreateCopy: TMyRec;
end;
function TMyRec.CreateCopy: TMyRec;
begin
New(Result.A);
Result.A^ := A^;
end;
var
R1, R2: TMyRec;
begin
New(R1.A); { I have to manually allocate memory for the pointer
before I can use the reocrd properly.
Even if I implement a record constructor to assist, I
still have to remember to call it. }
R1.A^ := 1;
R2 := R1;
R2.A^ := 2; //also changes R1.A^ because pointer is the same (or "tangled")
Writeln(R1.A^);
R2 := R1.CreateCopy;
R2.A^ := 3; //Now R1.A is different pointer so R1.A^ is unchanged
Writeln(R1.A^);
Dispose(R1.A);
Dispose(R2.A); { <-- Note that I have to remember to Dispose the additional
pointer that was allocated in CreateCopy }
end;
In a nutshell, it seems you're trying to sledgehammer records into doing things they're not really suited to doing.
They are great at making exact copies. They have simple memory management: Declare a record variable, and all memory is allocated. Variable goes out of scope and all memory is deallocated.
Edit
An example of how overriding the assignment operator can cause a memory leak.
var
LBigInt: TBigInt;
begin
LBigInt.SetValue(123);
WriteBigInt(LBigInt); { Passing the value by reference or by value depends
on how WriteBigInt is declared. }
end;
procedure WriteBigInt(ABigInt: TBigInt);
//ABigInt is a value parameter.
//This means it will be copied.
//It must use the overridden assignment operator,
// otherwise the point of the override is defeated.
begin
Writeln('The value is: ', ABigInt.ToString);
end;
//If the assignment overload allocated memory, this is the only place where an
//appropriate reference exists to deallocate.
//However, the very last thing you want to do is have method like this calling
//a cleanup routine to deallocate the memory....
//Not only would this litter your code with extra calls to accommodate a
//problematic design, would also create a risk that a simple change to taking
//ABigInt as a const parameter could suddenly lead to Access Violations.

Resources