суббота, 28 февраля 2015 г.

Another our screenshot

четверг, 26 февраля 2015 г.

Containers 10. About patterns and mixins

Original in Russian: http://18delphi.blogspot.ru/2013/03/blog-post_29.html

About containers. Table of contents

Now let’s talk about mixins a bit.

The theory can be read here:
https://en.wikipedia.org/wiki/Mixin

Instead, we’ll go in for practice.

Let’s look at the definition:
In object-oriented programming languages, a mixin is a class that contains a combination of methods from other classes. How such a combination is done depends on the language, but it is not by inheritance. If a combination contains all methods of combined classes, it is equivalent tomultiple inheritance.
Mixins encourage code reuse and can be used to avoid the inheritance ambiguity that multiple inheritance can cause (the "diamond problem"), or to work around lack of support for multiple inheritance in a language.
A mixin can also be viewed as an interface with implemented methods. When a class includes a mixin, the class implements the interface and includes, rather than inherits, all the mixin's attributes (fields, properties) and methods. They become part of the class during compilation.
A mixin can defer definition and binding of methods untilruntime, though attributes and instantiation parameters are still defined at compile time. This differs from the most widely used approach (which originated in the programming language Simula) of defining all attributes, methods and initialization at compile time.

Those who code on C++ are lucky, because they have multiple inheritance and the question “how to add mixin to the existing class hierarchy” does not arise. Delphi programmers are not lucky. There is no multiple inheritance. Actually, thank God – mixins are far more highly specialized tool then multiple inheritance.

I will write separately about the particular examples of using the mixins in life. And now let’s consider a purely abstract example illustrating only the technique of embedding the mixin class to the hierarchy of inheritance of designed classes.

In the previous article we had an example:

Let’s redraw the diagram in this way:


We can see that functionality of Stack'а has completely moved to StackPrim.
And two more classes have appeared – TintStackFromPersisten, inherited from TPersistent and StackPrim, and class TIntStackFromComponent, inherited from TComponent and StackPrim.

Multiple inheritance – you’d ask. Logically – yes. At the level of the diagrams arrows.

Let’s see how it all looks on Delphi:
StackPrim.imp.pas:

{$IfNDef StackPrim_imp}
 
{$Define StackPrim_imp}
 ItemsHolder = array of _ItemType_;
 
 _StackPrim_ = {mixin} class(_StackPrim_Parent_)
 private
 // private fields
   f_Items : ItemsHolder;
 public
 // public methods
   procedure Push(const anItem: _ItemType_);
   function Pop: _ItemType_;
 end;//_StackPrim_
 
{$Else StackPrim_imp}
 
// start class _StackPrim_
 
procedure _StackPrim_.Push(const anItem: _ItemType_);
var
 l_L : Integer;
begin
 l_L :=  Length(f_Items);
 SetLength(f_Items, l_L + 1);
 f_Items[l_L] := anItem;
end;//_StackPrim_.Push
 
function _StackPrim_.Pop: _ItemType_;
var
 l_L : Integer;
begin
 l_L :=  Length(f_Items) - 1;
 Result := f_Items[l_L];
 SetLength(f_Items, l_L);
end;//_StackPrim_.Pop
 
{$EndIf StackPrim_imp}

---------------------------------------------
Stack.imp.pas:

{$IfNDef Stack_imp}
 
{$Define Stack_imp}
 _StackPrim_Parent_ = TObject;
 {$Include StackPrim.imp.pas}
 _Stack_ = {mixin} class(_StackPrim_)
 end;//_Stack_
 
{$Else Stack_imp}
 
{$Include StackPrim.imp.pas}
 
{$EndIf Stack_imp}

---------------------------------------------
StringStack.pas:

unit StringStack;
 
interface
 
type
 _ItemType_ = AnsiString;
 {$Include Stack.imp.pas}
 TStringStack = class(_Stack_)
 end;//TStringStack
 
implementation
 
{$Include Stack.imp.pas}
 
end.

---------------------------------------------
IntStack.pas:

unit IntStack;
 
interface
 
type
 _ItemType_ = Integer;
 {$Include Stack.imp.pas}
 TIntStack = class(_Stack_)
 end;//TIntStack
 
implementation
 
{$Include Stack.imp.pas}
 
end

---------------------------------------------
!!! And there are two NEW classes:
---------------------------------------------
IntStackFromPersistent.pas:

unit IntStackFromPersistent;
 
interface
 
uses
  Classes
  ;
 
type
 _ItemType_ = Integer;
 _StackPrim_Parent_ = TPersistent;
 {$Include StackPrim.imp.pas}
 TIntStackFromPersistent = class(_StackPrim_)
 end;//TIntStackFromPersistent
 
implementation
 
{$Include StackPrim.imp.pas}
 
end.

---------------------------------------------
IntStackFromComponent.pas:

unit IntStackFromComponent;
 
interface
 
uses
  Classes
  ;
 
type
 _ItemType_ = Integer;
 _StackPrim_Parent_ = TComponent;
 {$Include StackPrim.imp.pas}
 TIntStackFromComponent = class(_StackPrim_)
 end;//TIntStackFromComponent
 
implementation
 
{$Include StackPrim.imp.pas}
 
end.

---------------------------------------------

As for me, it is fun :-) There is only ONE mixin, but it is added to FOUR different classes and even different places in the hierarchy of the inheritance.

Try it. May be you will like it.

In the next series I will try to tell WHY do I use it.

Containers 9. Special containers. Part 2

Original in Russian: http://18delphi.blogspot.ru/2013/07/2_18.html

About containers. Table of contents

The previous series was here - http://18delphi.blogspot.com/2015/02/containers-8-deriving-of-specific.html
And here - http://18delphi.blogspot.com/2015/02/containers-7-abstract-containers-part-2.html

Now let’s look how special containers have changed.

The model:

The code:
StandardAtomicList.imp.pas:
StandardAtomicList.imp.pas: 
{$IfNDef StandardAtomicList_imp}
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "StandardAtomicList.imp.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: Impurity::Class Shared Delphi Sand Box::SandBox::FinalContainers::StandardAtomicList
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Define StandardAtomicList_imp}
 _AtomicList_Parent_ = TRefcounted;
 {$Include ..\SandBox\AtomicList.imp.pas}
 _StandardAtomicList_ = {mixin} class(_AtomicList_)
 end;//_StandardAtomicList_
 
{$Else StandardAtomicList_imp}
 
{$Include ..\SandBox\AtomicList.imp.pas}
 
 
{$EndIf StandardAtomicList_imp}

IntegerList.pas: 
unit IntegerList;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "IntegerList.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: SimpleClass::Class Shared Delphi Sand Box::SandBox::FinalContainers::TIntegerList
//
// The list of Integer's
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Include ..\SandBox\sbDefine.inc}
 
interface
 
uses
  Refcounted,
  Classes,
  l3PtrLoc
  ;
 
type
 _ItemType_ = Integer;
 {$Include ..\SandBox\StandardAtomicList.imp.pas}
 TIntegerList = class(_StandardAtomicList_)
  {* The list of Integer's }
 end;//TIntegerList
 
implementation
 
uses
  RTLConsts,
  l3MemorySizeUtils
  ;
 
{$Include ..\SandBox\StandardAtomicList.imp.pas}
 
end.

Int64List.pas: 
unit Int64List;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "Int64List.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: SimpleClass::Class Shared Delphi Sand Box::SandBox::FinalContainers::TInt64List
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Include ..\SandBox\sbDefine.inc}
 
interface
 
uses
  Refcounted,
  Classes,
  l3PtrLoc
  ;
 
type
 _ItemType_ = Int64;
 {$Include ..\SandBox\StandardAtomicList.imp.pas}
 TInt64List = class(_StandardAtomicList_)
 end;//TInt64List
 
implementation
 
uses
  RTLConsts,
  l3MemorySizeUtils
  ;
 
{$Include ..\SandBox\StandardAtomicList.imp.pas}
 
end.


ByteList.pas: 
unit ByteList;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "ByteList.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: SimpleClass::Class Shared Delphi Sand Box::SandBox::FinalContainers::TByteList
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Include ..\SandBox\sbDefine.inc}
 
interface
 
uses
  Refcounted,
  Classes,
  l3PtrLoc
  ;
 
type
 _ItemType_ = Byte;
 {$Include ..\SandBox\StandardAtomicList.imp.pas}
 TByteList = class(_StandardAtomicList_)
 end;//TByteList
 
implementation
 
uses
  RTLConsts,
  l3MemorySizeUtils
  ;
 
{$Include ..\SandBox\StandardAtomicList.imp.pas}
 
end.


IUnknownRefList.pas: 
unit IUnknownRefList;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "IUnknownRefList.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: SimpleClass::Class Shared Delphi Sand Box::SandBox::FinalContainers::TIUnknownRefList
//
// The list of the REFERENCES to IUnknown
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Include ..\SandBox\sbDefine.inc}
 
interface
 
uses
  Refcounted,
  Classes,
  l3PtrLoc
  ;
 
type
 _ItemType_ = IUnknown;
 _InterfaceRefList_Parent_ = TRefcounted;
 {$Include ..\SandBox\InterfaceRefList.imp.pas}
 TIUnknownRefList = class(_InterfaceRefList_)
  {* The list of the REFERENCES to IUnknown }
 end;//TIUnknownRefList
 
implementation
 
uses
  RTLConsts,
  l3MemorySizeUtils
  ;
 
{$Include ..\SandBox\InterfaceRefList.imp.pas}
 
end.


IUnknownPtrList.pas: 
unit IUnknownPtrList;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "IUnknownPtrList.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: SimpleClass::Class Shared Delphi Sand Box::SandBox::FinalContainers::TIUnknownPtrList
//
// The list of the POINTERS to IUnknown
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Include ..\SandBox\sbDefine.inc}
 
interface
 
uses
  Refcounted,
  Classes,
  l3PtrLoc
  ;
 
type
 _ItemType_ = IUnknown;
 _InterfacePtrList_Parent_ = TRefcounted;
 {$Include ..\SandBox\InterfacePtrList.imp.pas}
 TIUnknownPtrList = class(_InterfacePtrList_)
  {* The list of the POINTERS to IUnknown }
 end;//TIUnknownPtrList
 
implementation
 
uses
  RTLConsts,
  l3MemorySizeUtils
  ;
 
{$Include ..\SandBox\InterfacePtrList.imp.pas}
 
end.


And the tests.

The model:
pic2

pic3


The code:

ListTest.imp.pas:
{$IfNDef ListTest_imp}
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBoxTest"
// The unit: "ListTest.imp.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: TestCaseMixIn::Class Shared Delphi Sand Box::SandBoxTest::FinalContainersTests::ListTest
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Define ListTest_imp}
{$If defined(nsTest)}
 _ListTest_ = class(TTestCase)
 protected
 // protected methods
   function CreateList: _ListType_;
     {* Creates the list for testing }
 end;//_ListTest_
{$IfEnd} //nsTest
 
{$Else ListTest_imp}
 
{$If defined(nsTest)}
 
// start class _ListTest_
 
function _ListTest_.CreateList: _ListType_;
//#UC START# *51E80E0D030D_51E80DD30125_var*
//#UC END# *51E80E0D030D_51E80DD30125_var*
begin
//#UC START# *51E80E0D030D_51E80DD30125_impl*
 Result := _ListType_.Create;
//#UC END# *51E80E0D030D_51E80DD30125_impl*
end;//_ListTest_.CreateList
 
{$IfEnd} //nsTest
 
{$EndIf ListTest_imp}


AtomicListTest.imp.pas:
{$IfNDef AtomicListTest_imp}
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBoxTest"
// The unit: "AtomicListTest.imp.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: TestCaseMixIn::Class Shared Delphi Sand Box::SandBoxTest::FinalContainersTests::AtomicListTest
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Define AtomicListTest_imp}
{$If defined(nsTest)}
 {$Include ..\SandBox\ListTest.imp.pas}
 _AtomicListTest_ = class(_ListTest_)
 private
 // private methods
   function RandomItem: _ItemType_;
 published
 // published methods
   procedure DoIt;
   procedure TestTwoLists;
   procedure TestInsert;
   procedure TestInsertAt0;
   procedure DeleteTest;
     {* The test of item deleting }
   procedure AddTest;
     {* The test of item adding }
   procedure RemoveTest;
     {* The test of item deleting by the value }
 end;//_AtomicListTest_
{$IfEnd} //nsTest
 
{$Else AtomicListTest_imp}
 
{$If defined(nsTest)}
 
{$Include ..\SandBox\ListTest.imp.pas}
 
// start class _AtomicListTest_
 
function _AtomicListTest_.RandomItem: _ItemType_;
//#UC START# *51E6ADE0016E_51E03FC80111_var*
var
 l_V : Cardinal;
//#UC END# *51E6ADE0016E_51E03FC80111_var*
begin
//#UC START# *51E6ADE0016E_51E03FC80111_impl*
 l_V := Random(1000);
 if (l_V > High(_ItemType_)) then
  Result := High(_ItemType_)
 else
  Result := l_V;
//#UC END# *51E6ADE0016E_51E03FC80111_impl*
end;//_AtomicListTest_.RandomItem
 
procedure _AtomicListTest_.DoIt;
//#UC START# *51DEB319037C_51E03FC80111_var*
const
 cCount = 1000;
var
 l_List : _ListType_;
 l_Count : IndexType;
 l_Index : IndexType;
//#UC END# *51DEB319037C_51E03FC80111_var*
begin
//#UC START# *51DEB319037C_51E03FC80111_impl*
 l_List := CreateList;
 try
  l_List.Count := cCount;
  Check(l_List.Count = cCount);
  Check(l_List.Capacity >= cCount);
 
  for l_Index := 0 to l_List.Count - 1 do
   Check(l_List[l_Index] = 0);
 
  l_Count := Random(cCount);
  l_List.Count := l_Count;
  Check(l_List.Count = l_Count, Format('We’ve allocated %d items. Count = %d', [l_Count, l_List.Count]));
  Check(l_List.Capacity >= l_Count, Format('We’ve allocated %d items. Capacity = %d', [l_Count, l_List.Capacity]));
 
  for l_Index := 0 to l_List.Count - 1 do
   Check(l_List[l_Index] = 0);
    
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51DEB319037C_51E03FC80111_impl*
end;//_AtomicListTest_.DoIt
 
procedure _AtomicListTest_.TestTwoLists;
//#UC START# *51DED6FC03C1_51E03FC80111_var*
const
 cCount = 1000;
var
 l_A : _ListType_;
 l_B : _ListType_;
 l_Index : IndexType;
 l_Value : _ItemType_;
//#UC END# *51DED6FC03C1_51E03FC80111_var*
begin
//#UC START# *51DED6FC03C1_51E03FC80111_impl*
 l_A := CreateList;
 try
  l_B := CreateList;
  try
   l_A.Count := cCount;
   for l_Index := 0 to l_A.Count - 1 do
   begin
    l_Value := RandomItem;
    l_A[l_Index] := l_Value;
    Check(l_A[l_Index] = l_Value);
   end;//for l_Index
 
   l_B.Count := l_A.Count;
   for l_Index := 0 to l_A.Count - 1 do
   begin
    l_B[l_Index] := l_A[l_Index];
   end;//for l_Index
 
   for l_Index := 0 to l_A.Count - 1 do
   begin
    Check(l_B[l_Index] = l_A[l_Index]);
   end;//for l_Index
  finally
   FreeAndNil(l_B);
  end;//try..finally
 finally
  FreeAndNil(l_A);
 end;//try..finally
//#UC END# *51DED6FC03C1_51E03FC80111_impl*
end;//_AtomicListTest_.TestTwoLists
 
procedure _AtomicListTest_.TestInsert;
//#UC START# *51E6AC74038B_51E03FC80111_var*
const
 cCount = 1000;
var
 l_List : _ListType_;
 l_Value : _ItemType_;
 l_Index : IndexType;
//#UC END# *51E6AC74038B_51E03FC80111_var*
begin
//#UC START# *51E6AC74038B_51E03FC80111_impl*
 l_List := CreateList;
 try
  for l_Index := 0 to cCount do
  begin
   l_Value := RandomItem;
   l_List.Insert(l_Index, l_Value);
   Check(l_List.Count = l_Index + 1);
   Check(l_List[l_Index] = l_Value);
  end;//for l_Index
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51E6AC74038B_51E03FC80111_impl*
end;//_AtomicListTest_.TestInsert
 
procedure _AtomicListTest_.TestInsertAt0;
//#UC START# *51E6B4260008_51E03FC80111_var*
const
 cCount = 1000;
var
 l_List : _ListType_;
 l_Value : _ItemType_;
 l_Index : IndexType;
//#UC END# *51E6B4260008_51E03FC80111_var*
begin
//#UC START# *51E6B4260008_51E03FC80111_impl*
 l_List := CreateList;
 try
  for l_Index := 0 to cCount do
  begin
   l_Value := RandomItem;
   l_List.Insert(0, l_Value);
   Check(l_List.Count = l_Index + 1);
   Check(l_List[0] = l_Value);
  end;//for l_Index
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51E6B4260008_51E03FC80111_impl*
end;//_AtomicListTest_.TestInsertAt0
 
procedure _AtomicListTest_.DeleteTest;
//#UC START# *51E7F6EF0285_51E03FC80111_var*
const
 cCount = 1000;
var
 l_List : _ListType_;
 l_Value : _ItemType_;
 l_Index : IndexType;
 l_Prev : _ItemType_;
//#UC END# *51E7F6EF0285_51E03FC80111_var*
begin
//#UC START# *51E7F6EF0285_51E03FC80111_impl*
 l_List := CreateList;
 try
  for l_Index := 0 to cCount do
  begin
   l_Value := RandomItem;
   l_List.Insert(l_Index, l_Value);
   Check(l_List.Count = l_Index + 1);
   Check(l_List[l_Index] = l_Value);
  end;//for l_Index
 
  while not l_List.Empty do
  begin
   l_Index := Random(l_List.Count - 1);
   if (l_Index < l_List.Count - 1) then
   begin
    l_Prev := l_List[l_Index + 1];
    l_List.Delete(l_Index);
    if l_List.Empty then
     break;
    Check(l_List[l_Index] = l_Prev);
   end//l_Index < l_List.Count - 1
   else
   begin
    if (l_Index = 0) then
     l_List.Delete(l_Index)
    else
    begin
     l_Prev := l_List[l_Index - 1];
     l_List.Delete(l_Index);
     if l_List.Empty then
      break;
     Check(l_List[l_Index - 1] = l_Prev);
    end;//l_Index = 0
   end;//l_Index < l_List.Count - 1
  end;//while l_List.Count
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51E7F6EF0285_51E03FC80111_impl*
end;//_AtomicListTest_.DeleteTest
 
procedure _AtomicListTest_.AddTest;
//#UC START# *51E80DC50154_51E03FC80111_var*
const
 cCount = 1000;
var
 l_List : _ListType_;
 l_Value : _ItemType_;
 l_Index : IndexType;
//#UC END# *51E80DC50154_51E03FC80111_var*
begin
//#UC START# *51E80DC50154_51E03FC80111_impl*
 l_List := CreateList;
 try
  for l_Index := 0 to cCount do
  begin
   l_Value := RandomItem;
   l_List.Add(l_Value);
   Check(l_List.Last = l_Value);
  end;//for l_Index
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51E80DC50154_51E03FC80111_impl*
end;//_AtomicListTest_.AddTest
 
procedure _AtomicListTest_.RemoveTest;
//#UC START# *51E8127802AF_51E03FC80111_var*
const
 cCount = 1000;
var
 l_List : _ListType_;
 l_Value : _ItemType_;
 l_Index : IndexType;
//#UC END# *51E8127802AF_51E03FC80111_var*
begin
//#UC START# *51E8127802AF_51E03FC80111_impl*
 l_List := CreateList;
 try
  for l_Index := 0 to cCount do
  begin
   l_Value := RandomItem;
   l_List.Add(l_Value);
   Check(l_List.Last = l_Value);
  end;//for l_Index
 
  while not l_List.Empty do
  begin
   l_Value := RandomItem;
   l_List.Remove(l_Value);
  end;//while not
   
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51E8127802AF_51E03FC80111_impl*
end;//_AtomicListTest_.RemoveTest
 
{$IfEnd} //nsTest
 
{$EndIf AtomicListTest_imp}

IUnknownRefListTest.pas:
unit IUnknownRefListTest;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBoxTest"
// The unit: "IUnknownRefListTest.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: TestCase::Class Shared Delphi Sand Box::SandBoxTest::FinalContainersTests::IUnknownRefListTest
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Include ..\SandBox\sbtDefine.inc}
 
interface
 
{$If defined(nsTest)}
uses
  TestFrameWork,
  IUnknownRefList
  ;
{$IfEnd} //nsTest
 
{$If defined(nsTest)}
type
 _ListType_ = TIUnknownRefList;
 {$Include ..\SandBox\ListTest.imp.pas}
 TIUnknownRefListTest = class(_ListTest_)
 published
 // published methods
   procedure DoIt;
 end;//TIUnknownRefListTest
{$IfEnd} //nsTest
 
implementation
 
{$If defined(nsTest)}
uses
  SysUtils
  ;
{$IfEnd} //nsTest
 
{$If defined(nsTest)}
 
{$Include ..\SandBox\ListTest.imp.pas}
 
// start class TIUnknownRefListTest
 
procedure TIUnknownRefListTest.DoIt;
//#UC START# *51E80B2F02CF_51E80B08039E_var*
var
 l_List : _ListType_;
//#UC END# *51E80B2F02CF_51E80B08039E_var*
begin
//#UC START# *51E80B2F02CF_51E80B08039E_impl*
 l_List := CreateList;
 try
  // - For now we do nothing
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51E80B2F02CF_51E80B08039E_impl*
end;//TIUnknownRefListTest.DoIt
 
{$IfEnd} //nsTest
 
initialization
 TestFramework.RegisterTest(TIUnknownRefListTest.Suite);
 
end.

Containers 8. Deriving of specific atomic containers from abstract ones

Original in Russian: http://18delphi.blogspot.ru/2013/07/blog-post_8789.html

About containers. Table of contents

The previous series was here - http://18delphi.blogspot.com/2015/02/containers-7-abstract-containers-part-2.html

Now let us derive from abstract containers of the previous series – the specific ones. As yet – atomic ones.

So. As usual.

The model:

The code:

IntegerList.pas:

unit IntegerList;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "IntegerList.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: SimpleClass::Class Shared Delphi Sand Box::SandBox::FinalContainers::TIntegerList
//
// The list of Integer's
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
// ! Fully generated from the model. It is not allowed to edit manually. !
 
interface
 
uses
  Refcounted,
  Classes,
  l3PtrLoc
  ;
 
type
 _ItemType_ = Integer;
 _AtomicList_Parent_ = TRefcounted;
 {$Include AtomicList.imp.pas}
 TIntegerList = class(_AtomicList_)
  {* The list of Integer's }
 end;//TIntegerList
 
implementation
 
uses
  RTLConsts,
  l3MemorySizeUtils
  ;
 
type _Instance_R_ = TIntegerList;
type _AtomicList_R_ = TIntegerList;
 
{$Include AtomicList.imp.pas}
 
end.

ByteList.pas: 
unit ByteList;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "ByteList.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: SimpleClass::Class Shared Delphi Sand Box::SandBox::FinalContainers::TByteList
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
// ! Fully generated from the model. It is not allowed to edit manually. !
 
interface
 
uses
  Refcounted,
  Classes,
  l3PtrLoc
  ;
 
type
 _ItemType_ = Byte;
 _AtomicList_Parent_ = TRefcounted;
 {$Include AtomicList.imp.pas}
 TByteList = class(_AtomicList_)
 end;//TByteList
 
implementation
 
uses
  RTLConsts,
  l3MemorySizeUtils
  ;
 
type _Instance_R_ = TByteList;
type _AtomicList_R_ = TByteList;
 
{$Include AtomicList.imp.pas}
 
end.


Int64List.pas: 
unit Int64List;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "Int64List.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: SimpleClass::Class Shared Delphi Sand Box::SandBox::FinalContainers::TInt64List
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
// ! Fully generated from the model. It is not allowed to edit manually. !
 
interface
 
uses
  Refcounted,
  Classes,
  l3PtrLoc
  ;
 
type
 _ItemType_ = Int64;
 _AtomicList_Parent_ = TRefcounted;
 {$Include AtomicList.imp.pas}
 TInt64List = class(_AtomicList_)
 end;//TInt64List
 
implementation
 
uses
  RTLConsts,
  l3MemorySizeUtils
  ;
 
type _Instance_R_ = TInt64List;
type _AtomicList_R_ = TInt64List;
 
{$Include AtomicList.imp.pas}
 
end.

The tests (picked out of the thin air, nevertheless they have the right to live).

The model of the tests:

The code of the tests:

IntegerListTest.pas:

unit IntegerListTest;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBoxTest"
// The unit: "IntegerListTest.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: TestCase::Class Shared Delphi Sand Box::SandBoxTest::FinalContainersTests::IntegerListTest
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
// ! Fully generated from the model. It is not allowed to edit manually. !
 
interface
 
uses
  TestFrameWork
  ;
 
type
 TIntegerListTest = class(TTestCase)
 published
 // published methods
   procedure DoIt;
   procedure TestTwoLists;
 end;//TIntegerListTest
 
implementation
 
uses
  IntegerList,
  SysUtils
  ;
 
// start class TIntegerListTest
 
procedure TIntegerListTest.DoIt;
//#UC START# *51DEB319037C_51DEB2FA00B0_var*
const
 cCount = 1000;
var
 l_List : TIntegerList;
 l_Count : IndexType;
 l_Index : IndexType;
//#UC END# *51DEB319037C_51DEB2FA00B0_var*
begin
//#UC START# *51DEB319037C_51DEB2FA00B0_impl*
 l_List := TIntegerList.Create;
 try
  l_List.Count := cCount;
  Check(l_List.Count = cCount);
  Check(l_List.Capacity >= cCount);
 
  for l_Index := 0 to l_List.Count - 1 do
   Check(l_List[l_Index] = 0);
 
  l_Count := Random(cCount);
  l_List.Count := l_Count;
  Check(l_List.Count = l_Count, Format('We’ve allocated %d items. Count = %d', [l_Count, l_List.Count]));
  Check(l_List.Capacity >= l_Count, Format('We’ve allocated %d items. Capacity = %d', [l_Count, l_List.Capacity]));
 
  for l_Index := 0 to l_List.Count - 1 do
   Check(l_List[l_Index] = 0);
    
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51DEB319037C_51DEB2FA00B0_impl*
end;//TIntegerListTest.DoIt
 
procedure TIntegerListTest.TestTwoLists;
//#UC START# *51DED6FC03C1_51DEB2FA00B0_var*
const
 cCount = 1000;
var
 l_A : TIntegerList;
 l_B : TIntegerList;
 l_Index : IndexType;
 l_Value : Integer;
//#UC END# *51DED6FC03C1_51DEB2FA00B0_var*
begin
//#UC START# *51DED6FC03C1_51DEB2FA00B0_impl*
 l_A := TIntegerList.Create;
 try
  l_B := TIntegerList.Create;
  try
   l_A.Count := cCount;
   for l_Index := 0 to l_A.Count - 1 do
   begin
    l_Value := Random(1000);
    l_A[l_Index] := l_Value;
    Check(l_A[l_Index] = l_Value);
   end;//for l_Index
 
   l_B.Count := l_A.Count;
   for l_Index := 0 to l_A.Count - 1 do
   begin
    l_B[l_Index] := l_A[l_Index];
   end;//for l_Index
 
   for l_Index := 0 to l_A.Count - 1 do
   begin
    Check(l_B[l_Index] = l_A[l_Index]);
   end;//for l_Index
  finally
   FreeAndNil(l_B);
  end;//try..finally
 finally
  FreeAndNil(l_A);
 end;//try..finally
//#UC END# *51DED6FC03C1_51DEB2FA00B0_impl*
end;//TIntegerListTest.TestTwoLists
 
initialization
 TestFramework.RegisterTest(TIntegerListTest.Suite);
 
end.


ByteListTest.pas: 
unit ByteListTest;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBoxTest"
// The unit: "ByteListTest.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: TestCase::Class Shared Delphi Sand Box::SandBoxTest::FinalContainersTests::ByteListTest
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
// ! Fully generated from the model. It is not allowed to edit manually. !
 
interface
 
uses
  TestFrameWork
  ;
 
type
 TByteListTest = class(TTestCase)
 published
 // published methods
   procedure DoIt;
 end;//TByteListTest
 
implementation
 
uses
  ByteList,
  SysUtils
  ;
 
// start class TByteListTest
 
procedure TByteListTest.DoIt;
//#UC START# *51DEE6960378_51DEE67C003A_var*
const
 cCount = 1000;
var
 l_List : TByteList;
 l_Count : IndexType;
 l_Index : IndexType;
//#UC END# *51DEE6960378_51DEE67C003A_var*
begin
//#UC START# *51DEE6960378_51DEE67C003A_impl*
 l_List := TByteList.Create;
 try
  l_List.Count := cCount;
  Check(l_List.Count = cCount);
  Check(l_List.Capacity >= cCount);
 
  for l_Index := 0 to l_List.Count - 1 do
   Check(l_List[l_Index] = 0);
 
  l_Count := Random(cCount);
  l_List.Count := l_Count;
  Check(l_List.Count = l_Count, Format('We’ve allocated %d items. Count = %d', [l_Count, l_List.Count]));
  Check(l_List.Capacity >= l_Count, Format('We’ve allocated %d items. Capacity = %d', [l_Count, l_List.Capacity]));
 
  for l_Index := 0 to l_List.Count - 1 do
   Check(l_List[l_Index] = 0);
    
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51DEE6960378_51DEE67C003A_impl*
end;//TByteListTest.DoIt
 
initialization
 TestFramework.RegisterTest(TByteListTest.Suite);
 
end.


Int64ListTest.pas: 
unit Int64ListTest;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBoxTest"
// The unit: "Int64ListTest.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: TestCase::Class Shared Delphi Sand Box::SandBoxTest::FinalContainersTests::Int64ListTest
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
// ! Fully generated from the model. It is not allowed to edit manually. !
 
interface
 
uses
  TestFrameWork
  ;
 
type
 TInt64ListTest = class(TTestCase)
 published
 // published methods
   procedure DoIt;
 end;//TInt64ListTest
 
implementation
 
uses
  Int64List,
  SysUtils
  ;
 
// start class TInt64ListTest
 
procedure TInt64ListTest.DoIt;
//#UC START# *51DEE90202A8_51DEE8E9025A_var*
const
 cCount = 1000;
var
 l_List : TInt64List;
 l_Count : IndexType;
 l_Index : IndexType;
//#UC END# *51DEE90202A8_51DEE8E9025A_var*
begin
//#UC START# *51DEE90202A8_51DEE8E9025A_impl*
 l_List := TInt64List.Create;
 try
  l_List.Count := cCount;
  Check(l_List.Count = cCount);
  Check(l_List.Capacity >= cCount);
 
  for l_Index := 0 to l_List.Count - 1 do
   Check(l_List[l_Index] = 0);
 
  l_Count := Random(cCount);
  l_List.Count := l_Count;
  Check(l_List.Count = l_Count, Format('We’ve allocated %d items. Count = %d', [l_Count, l_List.Count]));
  Check(l_List.Capacity >= l_Count, Format('We’ve allocated %d items. Capacity = %d', [l_Count, l_List.Capacity]));
 
  for l_Index := 0 to l_List.Count - 1 do
   Check(l_List[l_Index] = 0);
    
 finally
  FreeAndNil(l_List);
 end;//try..finally
//#UC END# *51DEE90202A8_51DEE8E9025A_impl*
end;//TInt64ListTest.DoIt
 
initialization
 TestFramework.RegisterTest(TInt64ListTest.Suite);
 
end.


The code is here - http://sourceforge.net/p/rumtmarc/code-0/19/tree/trunk/Blogger/SandBox and http://sourceforge.net/p/rumtmarc/code-0/19/tree/trunk/Blogger/SandBoxTest

Containers 7. Abstract containers. Part 2

Original in Russian: http://18delphi.blogspot.ru/2013/07/2.html

About containers. Table of contents

The previous series was here - http://18delphi.blogspot.com/2015/02/containers-6-abstract-containers.html

Let’s extend the functionality of the container by adding the “standard” container operations.

As usual we’ll start with the model:



And the code:

List.imp.pas:

{$IfNDef List_imp}
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "List.imp.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: Impurity::Class Shared Delphi Sand Box::SandBox::STLLike::List
//
// The abstract list of values
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Define List_imp}
 PItemType = ^_ItemType_;
 
const
  { Sizes }
 cItemSize = SizeOf(_ItemType_);
 
type
 IndexType = System.Integer;
 
 _List_ = {mixin} class(_List_Parent_)
  {* The abstract list of values }
 private
 // private fields
   f_Data : Tl3PtrLoc;
    {* That is actually the place to store data }
   f_Count : IndexType;
    {* Field for the property Count}
 private
 // private methods
   procedure ReAllocList(aNewCapacity: IndexType);
   procedure CheckIndex(anIndex: IndexType); // can raise EListError
     {* checks the validity of the index and raises an exception if it is incorrect }
   function ItemSlot(anIndex: IndexType): PItemType;
   function ExpandSize(aTargetSize: IndexType): Cardinal;
   procedure CheckSetItem(anIndex: IndexType); // can raise EListError
     {* Checks the validity of the index upon insert }
   procedure DirectInsert(anIndex: IndexType;
     const anItem: _ItemType_);
     {* Direct adding of the item. Without checking the validity of the index }
   procedure MoveItems(aDst: IndexType;
     aSrc: IndexType;
     aSize: Cardinal);
 protected
 // property methods
   procedure pm_SetCount(aValue: IndexType);
   function pm_GetCapacity: IndexType;
   procedure pm_SetCapacity(aValue: IndexType);
   function pm_GetItems(anIndex: IndexType): _ItemType_;
   procedure pm_SetItems(anIndex: IndexType; const aValue: _ItemType_);
   function pm_GetEmpty: Boolean;
   function pm_GetFirst: _ItemType_;
   function pm_GetLast: _ItemType_;
 protected
 // overridden protected methods
   procedure Cleanup; override;
     {* The function of object fields cleaning. }
 public
 // public methods
   procedure Delete(anIndex: IndexType); // can raise EListError
     {* delete the item with index anIndex }
   procedure Insert(anIndex: IndexType;
     const anItem: _ItemType_); // can raise EListError
     {* Adding of the item }
   procedure Add(const anItem: _ItemType_);
     {* Adds an item of the list }
   function IndexOf(const anItem: _ItemType_): IndexType;
     {* Returns the index of the list item or -1, if there is no item in the list }
   procedure Remove(const anIndex: _ItemType_);
     {* Deletes an item from the list }
   procedure Clear;
     {* Clears the list }
 public
 // public properties
   property Count: IndexType
     read f_Count
     write pm_SetCount;
     {* The number of items in the list }
   property Capacity: IndexType
     read pm_GetCapacity
     write pm_SetCapacity;
     {* The capacity of the list }
   property Items[anIndex: IndexType]: _ItemType_
     read pm_GetItems
     write pm_SetItems;
     default;
     {* The items of the list. }
   property Empty: Boolean
     read pm_GetEmpty;
     {* The list is empty }
   property First: _ItemType_
     read pm_GetFirst;
     {* The first item of the list }
   property Last: _ItemType_
     read pm_GetLast;
     {* The last item of the list }
 end;//_List_
 
{$Else List_imp}
 
// start class _List_
 
procedure _List_.ReAllocList(aNewCapacity: IndexType);
//#UC START# *51DEB8770017_51DEB07E03E4_var*
var
 l_Cap : Integer;
 l_Cnt : Integer;
//#UC END# *51DEB8770017_51DEB07E03E4_var*
begin
//#UC START# *51DEB8770017_51DEB07E03E4_impl*
 f_Data.SetSize(aNewCapacity * cItemSize);
 l_Cap := Self.Capacity;
 Assert(l_Cap >= aNewCapacity);
 l_Cnt := f_Count;
 if (l_Cap > l_Cnt) then
  System.FillChar(ItemSlot(l_Cnt)^, (l_Cap - l_Cnt) * cItemSize, 0);
//#UC END# *51DEB8770017_51DEB07E03E4_impl*
end;//_List_.ReAllocList
 
procedure _List_.CheckIndex(anIndex: IndexType); // can raise EListError
//#UC START# *51DEB95E00BD_51DEB07E03E4_var*
 
 procedure _Error;
 begin
  raise EListError.CreateFmt(SListIndexError + ' from (%d)', [anIndex, f_Count])
 end;
 
//#UC END# *51DEB95E00BD_51DEB07E03E4_var*
begin
//#UC START# *51DEB95E00BD_51DEB07E03E4_impl*
 if (anIndex < 0) or (anIndex >= f_Count) then
  _Error;
//#UC END# *51DEB95E00BD_51DEB07E03E4_impl*
end;//_List_.CheckIndex
 
function _List_.ItemSlot(anIndex: IndexType): PItemType;
//#UC START# *51DEBE2D008A_51DEB07E03E4_var*
//#UC END# *51DEBE2D008A_51DEB07E03E4_var*
begin
//#UC START# *51DEBE2D008A_51DEB07E03E4_impl*
 Result := PItemType(f_Data.AsPointer + anIndex * cItemSize);
 assert(Result <> nil);
//#UC END# *51DEBE2D008A_51DEB07E03E4_impl*
end;//_List_.ItemSlot
 
function _List_.ExpandSize(aTargetSize: IndexType): Cardinal;
//#UC START# *51DEC11F0058_51DEB07E03E4_var*
const
 cIncrArray : array [0..3] of Integer = (64 * 1024, 1024, 128, 4);
 cMaxForTwice : Integer = 1 * 1024 * 1024;
var
 I : Integer;
//#UC END# *51DEC11F0058_51DEB07E03E4_var*
begin
//#UC START# *51DEC11F0058_51DEB07E03E4_impl*
 Assert(aTargetSize > 0);
 
 Result := aTargetSize;
 if (Result > cMaxForTwice) then
 // we do not double large arrays, but even them to 1 Mb 
  Result := (aTargetSize div cMaxForTwice + 1) * cMaxForTwice
 else
 begin
  for I := 0 to High(cIncrArray) do
   if (aTargetSize > cIncrArray[I]) then
   begin
    Result := (aTargetSize div cIncrArray[I]) * cIncrArray[I] * 2;
    Break;
   end;//aTargetSize > cIncrArray[I]
 end;//Result > cMaxForTwic
//#UC END# *51DEC11F0058_51DEB07E03E4_impl*
end;//_List_.ExpandSize
 
procedure _List_.CheckSetItem(anIndex: IndexType); // can raise EListError
//#UC START# *51DECAA8035E_51DEB07E03E4_var*
//#UC END# *51DECAA8035E_51DEB07E03E4_var*
begin
//#UC START# *51DECAA8035E_51DEB07E03E4_impl*
 CheckIndex(anIndex);
//#UC END# *51DECAA8035E_51DEB07E03E4_impl*
end;//_List_.CheckSetItem
 
procedure _List_.DirectInsert(anIndex: IndexType;
  const anItem: _ItemType_);
//#UC START# *51E6A2AA02E4_51DEB07E03E4_var*
var
 l_Cap   : Integer;
 l_Count : Integer;
//#UC END# *51E6A2AA02E4_51DEB07E03E4_var*
begin
//#UC START# *51E6A2AA02E4_51DEB07E03E4_impl*
 l_Count := f_Count;
 l_Cap := Self.Capacity;
 if (l_Count >= l_Cap) then
  ReAllocList(ExpandSize(l_Cap + 1));
 { Make room for the inserted item. }
 Dec(l_Count, anIndex);
 if (l_Count > 0) then
 begin
  MoveItems(anIndex + 1, anIndex + 0, l_Count);
  {$If not defined(l3Items_IsAtomic)}
  FillChar(PMem(ItemSlot(anIndex))^, cItemSize, 0);
  // - To ensure that there is no odd reference to the lines and/or the interfaces 
  {$IfEnd}
 end;//l_Count > 0
 FillItem(ItemSlot(anIndex)^, anItem);
 Inc(f_Count);
 {$IfDef l3Items_IsAtomic}
 Assert(ItemSlot(anIndex)^ = anItem);
 {$Else  l3Items_IsAtomic}
 {$If (SizeOf(_ItemType_) <= 4) AND not Defined(l3Items_IsProcedured)}
 Assert(ItemSlot(anIndex)^ = anItem);
 {$IfEnd}
 {$EndIf l3Items_IsAtomic}
//#UC END# *51E6A2AA02E4_51DEB07E03E4_impl*
end;//_List_.DirectInsert
 
procedure _List_.MoveItems(aDst: IndexType;
  aSrc: IndexType;
  aSize: Cardinal);
//#UC START# *51E6A8190252_51DEB07E03E4_var*
type
 PInteger = ^Integer;
var
 l_Sz : Integer;
 l_S  : Integer;
 l_D  : Integer;
 l_B  : PMem;
//#UC END# *51E6A8190252_51DEB07E03E4_var*
begin
//#UC START# *51E6A8190252_51DEB07E03E4_impl*
 if (aSize > 0) then
 begin
  l_B := f_Data.AsPointer;
  l_S := aSrc * cItemSize;
  l_D := aDst * cItemSize;
  l_Sz := aSize * cItemSize;
  if (l_Sz = SizeOf(Integer)) then
  begin
   PInteger(l_B + l_D)^ := PInteger(l_B + l_S)^;
   Exit;
  end//l_Sz = SizeOf(Integer)
  else
   Move((l_B + l_S)^, (l_B + l_D)^, l_Sz);
 end;//aSize > 0
//#UC END# *51E6A8190252_51DEB07E03E4_impl*
end;//_List_.MoveItems
 
procedure _List_.Delete(anIndex: IndexType); // can raise EListError
//#UC START# *51E6A2660270_51DEB07E03E4_var*
var
 l_P : PItemType;
//#UC END# *51E6A2660270_51DEB07E03E4_var*
begin
//#UC START# *51E6A2660270_51DEB07E03E4_impl*
 CheckIndex(anIndex);
 l_P := ItemSlot(anIndex);
 Dec(f_Count);
 FreeItem(l_P^);
 if (anIndex <> f_Count) then
  MoveItems(anIndex, Succ(anIndex), f_Count-anIndex);
//#UC END# *51E6A2660270_51DEB07E03E4_impl*
end;//_List_.Delete
 
procedure _List_.Insert(anIndex: IndexType;
  const anItem: _ItemType_); // can raise EListError
//#UC START# *51E6A3140016_51DEB07E03E4_var*
 
 procedure _Error;
 begin
  raise EListError.CreateFmt(SListIndexError, [anIndex]);
 end;
 
//#UC END# *51E6A3140016_51DEB07E03E4_var*
begin
//#UC START# *51E6A3140016_51DEB07E03E4_impl*
 if (anIndex < 0) or (anIndex > f_Count) then
  _Error;
 DirectInsert(anIndex, anItem) 
//#UC END# *51E6A3140016_51DEB07E03E4_impl*
end;//_List_.Insert
 
procedure _List_.Add(const anItem: _ItemType_);
//#UC START# *51E80192036C_51DEB07E03E4_var*
//#UC END# *51E80192036C_51DEB07E03E4_var*
begin
//#UC START# *51E80192036C_51DEB07E03E4_impl*
 DirectInsert(f_Count, anItem);
//#UC END# *51E80192036C_51DEB07E03E4_impl*
end;//_List_.Add
 
function _List_.IndexOf(const anItem: _ItemType_): IndexType;
//#UC START# *51E801D503C5_51DEB07E03E4_var*
var
 l_Index : IndexType;
//#UC END# *51E801D503C5_51DEB07E03E4_var*
begin
//#UC START# *51E801D503C5_51DEB07E03E4_impl*
 Result := -1;
 // - let’s be pessimistic
 for l_Index := 0 to f_Count - 1 do
 begin
  if IsSame(ItemSlot(l_Index)^, anItem) then
  begin
   Result := l_Index;
   break;
  end;//IsSame(ItemSlot(l_Index)^, anItem)
 end;//for l_Index
//#UC END# *51E801D503C5_51DEB07E03E4_impl*
end;//_List_.IndexOf
 
procedure _List_.Remove(const anIndex: _ItemType_);
//#UC START# *51E802290167_51DEB07E03E4_var*
var
 l_Index : IndexType;
//#UC END# *51E802290167_51DEB07E03E4_var*
begin
//#UC START# *51E802290167_51DEB07E03E4_impl*
 l_Index := IndexOf(anIndex);
 if (l_Index >= 0) then
  Delete(l_Index);
//#UC END# *51E802290167_51DEB07E03E4_impl*
end;//_List_.Remove
 
procedure _List_.Clear;
//#UC START# *51E8026302B4_51DEB07E03E4_var*
//#UC END# *51E8026302B4_51DEB07E03E4_var*
begin
//#UC START# *51E8026302B4_51DEB07E03E4_impl*
 Count := 0;
//#UC END# *51E8026302B4_51DEB07E03E4_impl*
end;//_List_.Clear
 
procedure _List_.pm_SetCount(aValue: IndexType);
//#UC START# *51DEB1ED0017_51DEB07E03E4set_var*
 
 procedure SayBadCount(aNewCount: LongInt);
 begin
  raise EListError.CreateFmt(sListIndexError, [aNewCount]);
 end;
 
var
 l_Ptr   : PItemType;
 {$IfNDef l3Items_IsUnrefcounted}
 l_Index : Integer;
 {$EndIf  l3Items_IsUnrefcounted}
//#UC END# *51DEB1ED0017_51DEB07E03E4set_var*
begin
//#UC START# *51DEB1ED0017_51DEB07E03E4set_impl*
 if (aValue < 0) then
  SayBadCount(aValue);
 if (aValue < f_Count) then
 begin
  l_Ptr := ItemSlot(aValue);
  {$IfDef l3Items_IsUnrefcounted}
  System.FillChar(l_Ptr^, (f_Count - 1 - aValue) * cItemSize, 0);
  {$Else  l3Items_IsUnrefcounted}
  for l_Index := aValue to f_Count - 1 do
  begin
   FreeItem(l_Ptr^);
   Inc(PMem(l_Ptr), cItemSize);
  end;//for i
  {$EndIf  l3Items_IsUnrefcounted}
 end//aValue < f_Count
 else
 if (aValue > Self.Capacity) then
  ReAllocList(ExpandSize(aValue));
 if (f_Count < aValue) then
  System.FillChar(ItemSlot(f_Count)^, (aValue - f_Count) * cItemSize, 0);
 f_Count := aValue;
//#UC END# *51DEB1ED0017_51DEB07E03E4set_impl*
end;//_List_.pm_SetCount
 
function _List_.pm_GetCapacity: IndexType;
//#UC START# *51DEB20E0130_51DEB07E03E4get_var*
//#UC END# *51DEB20E0130_51DEB07E03E4get_var*
begin
//#UC START# *51DEB20E0130_51DEB07E03E4get_impl*
 Result := f_Data.GetSize div cItemSize;
//#UC END# *51DEB20E0130_51DEB07E03E4get_impl*
end;//_List_.pm_GetCapacity
 
procedure _List_.pm_SetCapacity(aValue: IndexType);
//#UC START# *51DEB20E0130_51DEB07E03E4set_var*
 
 procedure SayBadCap(aNewCapacity: IndexType);
 begin
  raise EListError.CreateFmt(sListIndexError, [aNewCapacity]);
 end;
 
//#UC END# *51DEB20E0130_51DEB07E03E4set_var*
begin
//#UC START# *51DEB20E0130_51DEB07E03E4set_impl*
 if (aValue < 0) then
  SayBadCap(aValue);
 if (pm_GetCapacity <> aValue) then
 begin
  { If the list is shrinking, then update _Count for the smaller size. }
  if (aValue < f_Count) then
   Count := aValue;
  ReAllocList(aValue);
 end;//GetCapacity(Self) <> aValue
//#UC END# *51DEB20E0130_51DEB07E03E4set_impl*
end;//_List_.pm_SetCapacity
 
function _List_.pm_GetItems(anIndex: IndexType): _ItemType_;
//#UC START# *51DECA1202C5_51DEB07E03E4get_var*
//#UC END# *51DECA1202C5_51DEB07E03E4get_var*
begin
//#UC START# *51DECA1202C5_51DEB07E03E4get_impl*
 CheckIndex(anIndex);
 Result := ItemSlot(anIndex)^;
//#UC END# *51DECA1202C5_51DEB07E03E4get_impl*
end;//_List_.pm_GetItems
 
procedure _List_.pm_SetItems(anIndex: IndexType; const aValue: _ItemType_);
//#UC START# *51DECA1202C5_51DEB07E03E4set_var*
{$IfNDef l3Items_IsAtomic}
var
 l_P : PItemType;
{$EndIf  l3Items_IsAtomic}
//#UC END# *51DECA1202C5_51DEB07E03E4set_var*
begin
//#UC START# *51DECA1202C5_51DEB07E03E4set_impl*
 CheckSetItem(anIndex);
 {$IfDef l3Items_IsAtomic}
 PItemType(ItemSlot(anIndex))^ := aValue;
 {$Else  l3Items_IsAtomic}
 l_P := PItemType(ItemSlot(anIndex));
 if not IsSame(l_P^, aValue) then
 begin
  FreeItem(l_P^);
  FillItem(l_P^, aValue);
 end;//not IsSame(l_P^, anItem)
 {$EndIf l3Items_IsAtomic}
//#UC END# *51DECA1202C5_51DEB07E03E4set_impl*
end;//_List_.pm_SetItems
 
function _List_.pm_GetEmpty: Boolean;
//#UC START# *51E7FDAC023D_51DEB07E03E4get_var*
//#UC END# *51E7FDAC023D_51DEB07E03E4get_var*
begin
//#UC START# *51E7FDAC023D_51DEB07E03E4get_impl*
 Result := (Count = 0);
//#UC END# *51E7FDAC023D_51DEB07E03E4get_impl*
end;//_List_.pm_GetEmpty
 
function _List_.pm_GetFirst: _ItemType_;
//#UC START# *51E8070603AC_51DEB07E03E4get_var*
//#UC END# *51E8070603AC_51DEB07E03E4get_var*
begin
//#UC START# *51E8070603AC_51DEB07E03E4get_impl*
 Result := Items[0];
//#UC END# *51E8070603AC_51DEB07E03E4get_impl*
end;//_List_.pm_GetFirst
 
function _List_.pm_GetLast: _ItemType_;
//#UC START# *51E8074101B5_51DEB07E03E4get_var*
//#UC END# *51E8074101B5_51DEB07E03E4get_var*
begin
//#UC START# *51E8074101B5_51DEB07E03E4get_impl*
 Result := Items[f_Count - 1];
//#UC END# *51E8074101B5_51DEB07E03E4get_impl*
end;//_List_.pm_GetLast
 
procedure _List_.Cleanup;
//#UC START# *479731C50290_51DEB07E03E4_var*
//#UC END# *479731C50290_51DEB07E03E4_var*
begin
//#UC START# *479731C50290_51DEB07E03E4_impl*
 Count := 0;
 f_Data.SetSize(0);
 inherited;
//#UC END# *479731C50290_51DEB07E03E4_impl*
end;//_List_.Cleanup
 
{$EndIf List_imp}

InterfacePtrList.imp.pas:

{$IfNDef InterfacePtrList_imp}
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "InterfacePtrList.imp.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: Impurity::Class Shared Delphi Sand Box::SandBox::STLLike::InterfacePtrList
//
// The list of the pointers to the interfaces. Does not have its items
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Define InterfacePtrList_imp}
 _List_Parent_ = _InterfacePtrList_Parent_;
 {$Include ..\SandBox\List.imp.pas}
 _InterfacePtrList_ = {mixin} class(_List_)
  {* The list of the pointers to the interfaces. Does not have its items }
 end;//_InterfacePtrList_
 
{$Else InterfacePtrList_imp}
 
// start class _InterfacePtrList_
 
procedure FillItem(var thePlace: _ItemType_;
  const aFrom: _ItemType_); forward;
 
function IsSame(const A: _ItemType_;
  const B: _ItemType_): Boolean; forward;
 
procedure FreeItem(var thePlace: _ItemType_);
//#UC START# *51DEC20B01D7_51E8098001DC_var*
//#UC END# *51DEC20B01D7_51E8098001DC_var*
begin
//#UC START# *51DEC20B01D7_51E8098001DC_impl*
 !!! Needs to be implemented !!!
//#UC END# *51DEC20B01D7_51E8098001DC_impl*
end;//FreeItem
 
procedure FillItem(var thePlace: _ItemType_;
  const aFrom: _ItemType_);
//#UC START# *51DECB440087_51E8098001DC_var*
//#UC END# *51DECB440087_51E8098001DC_var*
begin
//#UC START# *51DECB440087_51E8098001DC_impl*
 !!! Needs to be implemented !!!
//#UC END# *51DECB440087_51E8098001DC_impl*
end;//FillItem
 
function IsSame(const A: _ItemType_;
  const B: _ItemType_): Boolean;
//#UC START# *51DECB820261_51E8098001DC_var*
//#UC END# *51DECB820261_51E8098001DC_var*
begin
//#UC START# *51DECB820261_51E8098001DC_impl*
 !!! Needs to be implemented !!!
//#UC END# *51DECB820261_51E8098001DC_impl*
end;//IsSame
 
{$Include ..\SandBox\List.imp.pas}
 
 
{$EndIf InterfacePtrList_imp}

InterfaceRefList.imp.pas:

{$IfNDef InterfaceRefList_imp}
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "InterfaceRefList.imp.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: Impurity::Class Shared Delphi Sand Box::SandBox::STLLike::InterfaceRefList
//
// The list of the references to the interfaces. It has its items
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Define InterfaceRefList_imp}
 _List_Parent_ = _InterfaceRefList_Parent_;
 {$Include ..\SandBox\List.imp.pas}
 _InterfaceRefList_ = {mixin} class(_List_)
  {* The list of the references to the interfaces. It has its items }
 end;//_InterfaceRefList_
 
{$Else InterfaceRefList_imp}
 
// start class _InterfaceRefList_
 
procedure FillItem(var thePlace: _ItemType_;
  const aFrom: _ItemType_); forward;
 
function IsSame(const A: _ItemType_;
  const B: _ItemType_): Boolean; forward;
 
procedure FreeItem(var thePlace: _ItemType_);
//#UC START# *51DEC20B01D7_51E809AD001D_var*
//#UC END# *51DEC20B01D7_51E809AD001D_var*
begin
//#UC START# *51DEC20B01D7_51E809AD001D_impl*
 thePlace := nil;
//#UC END# *51DEC20B01D7_51E809AD001D_impl*
end;//FreeItem
 
procedure FillItem(var thePlace: _ItemType_;
  const aFrom: _ItemType_);
//#UC START# *51DECB440087_51E809AD001D_var*
//#UC END# *51DECB440087_51E809AD001D_var*
begin
//#UC START# *51DECB440087_51E809AD001D_impl*
 thePlace := afrom;
//#UC END# *51DECB440087_51E809AD001D_impl*
end;//FillItem
 
function IsSame(const A: _ItemType_;
  const B: _ItemType_): Boolean;
//#UC START# *51DECB820261_51E809AD001D_var*
//#UC END# *51DECB820261_51E809AD001D_var*
begin
//#UC START# *51DECB820261_51E809AD001D_impl*
 Result := (A = B);
//#UC END# *51DECB820261_51E809AD001D_impl*
end;//IsSame
 
{$Include ..\SandBox\List.imp.pas}
 
 
{$EndIf InterfaceRefList_imp}

Containers 6. Abstract containers


Original in Russian: http://18delphi.blogspot.ru/2013/07/blog-post_3683.html

About containers. Table of contents

Now I want to tell about the practice of creating “pattern” container in “STL style”.

FOR NOW – WITHOUT the “true” Generics (http://18delphi.blogspot.com/2015/02/containers-3-generics-and-without.html). They ALSO can be used. But FOR NOW – there is a NUMBER OF UNCLOSED errors, which for some reason Embarcadero does not hurry to close. That is a weak point. What to say. Even my error (http://qc.embarcadero.com/wc/qcmain.aspx?d=116040 http://18delphi.blogspot.com/2013/05/xe4.html) - has been "kind of corrected", but not closed. Even so that was a minor matter. If I get it my way right...

One remark. Despite the fact that in STL such containers are called vector, I’ve decided to keep continuity with Delphi and name it List.

So. As usual.

The model:



The code:

List.imp.pas:

{$IfNDef List_imp}
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "List.imp.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: Impurity::Class Shared Delphi Sand Box::SandBox::STLLike::List
//
// The abstract list of values
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Define List_imp}
 PItemType = ^_ItemType_;
 
const
  { Sizes }
 cItemSize = SizeOf(_ItemType_);
 
type
 IndexType = System.Integer;
 
 _List_ = {mixin} class(_List_Parent_)
  {* The abstract list of values }
 private
 // private fields
   f_Data : Tl3PtrLoc;
   f_Count : IndexType;
    {* The field for the property Count}
 private
 // private methods
   procedure ReAllocList(aNewCapacity: IndexType);
   procedure CheckIndex(anIndex: IndexType); // can raise EListError
     {* checks the validity of the index and raises an exception if it is incorrect }
   function ItemSlot(anIndex: IndexType): PItemType;
   function ExpandSize(aTargetSize: IndexType): Cardinal;
   procedure CheckSetItem(anIndex: IndexType); // can raise EListError
     {* Checks the validity of the index upon insert }
 protected
 // property methods
   procedure pm_SetCount(aValue: IndexType);
   function pm_GetCapacity: IndexType;
   procedure pm_SetCapacity(aValue: IndexType);
   function pm_GetItems(anIndex: IndexType): _ItemType_;
   procedure pm_SetItems(anIndex: IndexType; const aValue: _ItemType_);
 protected
 // overridden protected methods
   procedure Cleanup; override;
     {* The function of object fields cleaning. }
 public
 // public properties
   property Count: IndexType
     read f_Count
     write pm_SetCount;
   property Capacity: IndexType
     read pm_GetCapacity
     write pm_SetCapacity;
   property Items[anIndex: IndexType]: _ItemType_
     read pm_GetItems
     write pm_SetItems;
     default;
     {* The items of the list. }
 end;//_List_
 
{$Else List_imp}
 
// start class _List_
 
procedure _List_.ReAllocList(aNewCapacity: IndexType);
//#UC START# *51DEB8770017_51DEB07E03E4_var*
var
 l_Cap : Integer;
 l_Cnt : Integer;
//#UC END# *51DEB8770017_51DEB07E03E4_var*
begin
//#UC START# *51DEB8770017_51DEB07E03E4_impl*
 f_Data.SetSize(aNewCapacity * cItemSize);
 l_Cap := Self.Capacity;
 Assert(l_Cap >= aNewCapacity);
 l_Cnt := f_Count;
 if (l_Cap > l_Cnt) then
  System.FillChar(ItemSlot(l_Cnt)^, (l_Cap - l_Cnt) * cItemSize, 0);
//#UC END# *51DEB8770017_51DEB07E03E4_impl*
end;//_List_.ReAllocList
 
procedure _List_.CheckIndex(anIndex: IndexType); // can raise EListError
//#UC START# *51DEB95E00BD_51DEB07E03E4_var*
 
 procedure _Error;
 begin
  raise EListError.CreateFmt(SListIndexError + ' from (%d)', [anIndex, f_Count])
 end;
 
//#UC END# *51DEB95E00BD_51DEB07E03E4_var*
begin
//#UC START# *51DEB95E00BD_51DEB07E03E4_impl*
 if (anIndex < 0) or (anIndex >= f_Count) then
  _Error;
//#UC END# *51DEB95E00BD_51DEB07E03E4_impl*
end;//_List_.CheckIndex
 
function _List_.ItemSlot(anIndex: IndexType): PItemType;
//#UC START# *51DEBE2D008A_51DEB07E03E4_var*
//#UC END# *51DEBE2D008A_51DEB07E03E4_var*
begin
//#UC START# *51DEBE2D008A_51DEB07E03E4_impl*
 Result := PItemType(f_Data.AsPointer + anIndex * cItemSize);
 assert(Result <> nil);
//#UC END# *51DEBE2D008A_51DEB07E03E4_impl*
end;//_List_.ItemSlot
 
function _List_.ExpandSize(aTargetSize: IndexType): Cardinal;
//#UC START# *51DEC11F0058_51DEB07E03E4_var*
const
 cIncrArray : array [0..3] of Integer = (64 * 1024, 1024, 128, 4);
 cMaxForTwice : Integer = 1 * 1024 * 1024;
var
 I : Integer;
//#UC END# *51DEC11F0058_51DEB07E03E4_var*
begin
//#UC START# *51DEC11F0058_51DEB07E03E4_impl*
 Assert(aTargetSize > 0);
 
 Result := aTargetSize;
 if (Result > cMaxForTwice) then
 // we do not double large arrays, but even them to 1 Mb
  Result := (aTargetSize div cMaxForTwice + 1) * cMaxForTwice
 else
 begin
  for I := 0 to High(cIncrArray) do
   if (aTargetSize > cIncrArray[I]) then
   begin
    Result := (aTargetSize div cIncrArray[I]) * cIncrArray[I] * 2;
    Break;
   end;//aTargetSize > cIncrArray[I]
 end;//Result > cMaxForTwic
//#UC END# *51DEC11F0058_51DEB07E03E4_impl*
end;//_List_.ExpandSize
 
procedure _List_.CheckSetItem(anIndex: IndexType); // can raise EListError
//#UC START# *51DECAA8035E_51DEB07E03E4_var*
//#UC END# *51DECAA8035E_51DEB07E03E4_var*
begin
//#UC START# *51DECAA8035E_51DEB07E03E4_impl*
 CheckIndex(anIndex);
//#UC END# *51DECAA8035E_51DEB07E03E4_impl*
end;//_List_.CheckSetItem
 
procedure _List_.pm_SetCount(aValue: IndexType);
//#UC START# *51DEB1ED0017_51DEB07E03E4set_var*
 
 procedure SayBadCount(aNewCount: LongInt);
 begin
  raise EListError.CreateFmt(sListIndexError, [aNewCount]);
 end;
 
var
 l_Ptr   : PItemType;
 {$IfNDef l3Items_IsUnrefcounted}
 l_Index : Integer;
 {$EndIf  l3Items_IsUnrefcounted}
//#UC END# *51DEB1ED0017_51DEB07E03E4set_var*
begin
//#UC START# *51DEB1ED0017_51DEB07E03E4set_impl*
 if (aValue < 0) then
  SayBadCount(aValue);
 if (aValue < f_Count) then
 begin
  l_Ptr := ItemSlot(aValue);
  {$IfDef l3Items_IsUnrefcounted}
  System.FillChar(l_Ptr^, (f_Count - 1 - aValue) * cItemSize, 0);
  {$Else  l3Items_IsUnrefcounted}
  for l_Index := aValue to f_Count - 1 do
  begin
   FreeItem(l_Ptr^);
   Inc(PMem(l_Ptr), cItemSize);
  end;//for i
  {$EndIf  l3Items_IsUnrefcounted}
 end//aValue < f_Count
 else
 if (aValue > Self.Capacity) then
  ReAllocList(ExpandSize(aValue));
 if (f_Count < aValue) then
  System.FillChar(ItemSlot(f_Count)^, (aValue - f_Count) * cItemSize, 0);
 f_Count := aValue;
//#UC END# *51DEB1ED0017_51DEB07E03E4set_impl*
end;//_List_.pm_SetCount
 
function _List_.pm_GetCapacity: IndexType;
//#UC START# *51DEB20E0130_51DEB07E03E4get_var*
//#UC END# *51DEB20E0130_51DEB07E03E4get_var*
begin
//#UC START# *51DEB20E0130_51DEB07E03E4get_impl*
 Result := f_Data.GetSize div cItemSize;
//#UC END# *51DEB20E0130_51DEB07E03E4get_impl*
end;//_List_.pm_GetCapacity
 
procedure _List_.pm_SetCapacity(aValue: IndexType);
//#UC START# *51DEB20E0130_51DEB07E03E4set_var*
 
 procedure SayBadCap(aNewCapacity: IndexType);
 begin
  raise EListError.CreateFmt(sListIndexError, [aNewCapacity]);
 end;
 
//#UC END# *51DEB20E0130_51DEB07E03E4set_var*
begin
//#UC START# *51DEB20E0130_51DEB07E03E4set_impl*
 if (aValue < 0) then
  SayBadCap(aValue);
 if (pm_GetCapacity <> aValue) then
 begin
  { If the list is shrinking, then update _Count for the smaller size. }
  if (aValue < f_Count) then
   Count := aValue;
  ReAllocList(aValue);
 end;//GetCapacity(Self) <> aValue
//#UC END# *51DEB20E0130_51DEB07E03E4set_impl*
end;//_List_.pm_SetCapacity
 
function _List_.pm_GetItems(anIndex: IndexType): _ItemType_;
//#UC START# *51DECA1202C5_51DEB07E03E4get_var*
//#UC END# *51DECA1202C5_51DEB07E03E4get_var*
begin
//#UC START# *51DECA1202C5_51DEB07E03E4get_impl*
 CheckIndex(anIndex);
 Result := ItemSlot(anIndex)^;
//#UC END# *51DECA1202C5_51DEB07E03E4get_impl*
end;//_List_.pm_GetItems
 
procedure _List_.pm_SetItems(anIndex: IndexType; const aValue: _ItemType_);
//#UC START# *51DECA1202C5_51DEB07E03E4set_var*
{$IfNDef l3Items_IsAtomic}
var
 l_P : PItemType;
{$EndIf  l3Items_IsAtomic}
//#UC END# *51DECA1202C5_51DEB07E03E4set_var*
begin
//#UC START# *51DECA1202C5_51DEB07E03E4set_impl*
 CheckSetItem(anIndex);
 {$IfDef l3Items_IsAtomic}
 PItemType(ItemSlot(anIndex))^ := aValue;
 {$Else  l3Items_IsAtomic}
 l_P := PItemType(ItemSlot(anIndex));
 if not IsSame(l_P^, aValue) then
 begin
  FreeItem(l_P^);
  FillItem(l_P^, aValue);
 end;//not IsSame(l_P^, anItem)
 {$EndIf l3Items_IsAtomic}
//#UC END# *51DECA1202C5_51DEB07E03E4set_impl*
end;//_List_.pm_SetItems
 
procedure _List_.Cleanup;
//#UC START# *479731C50290_51DEB07E03E4_var*
//#UC END# *479731C50290_51DEB07E03E4_var*
begin
//#UC START# *479731C50290_51DEB07E03E4_impl*
 Count := 0;
 f_Data.SetSize(0);
 inherited;
//#UC END# *479731C50290_51DEB07E03E4_impl*
end;//_List_.Cleanup
 
{$EndIf List_imp}

UnrefcountedListPrim.imp.pas:

{$IfNDef UnrefcountedListPrim_imp}
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "UnrefcountedListPrim.imp.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: Impurity::Class Shared Delphi Sand Box::SandBox::STLLike::UnrefcountedListPrim
//
// The list of values without any reference counting
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Define UnrefcountedListPrim_imp}
 {$Define l3Items_IsUnrefcounted}
 
 _List_Parent_ = _UnrefcountedListPrim_Parent_;
 {$Include List.imp.pas}
 _UnrefcountedListPrim_ = {mixin} class(_List_)
  {* The list of values without any reference counting }
 end;//_UnrefcountedListPrim_
 
{$Else UnrefcountedListPrim_imp}
 
// start class _UnrefcountedListPrim_
 
function IsSame(const A: _ItemType_;
  const B: _ItemType_): Boolean;
//#UC START# *51DECB820261_51DED02E0163_var*
//#UC END# *51DECB820261_51DED02E0163_var*
begin
//#UC START# *51DECB820261_51DED02E0163_impl*
 Result := (A = B);
//#UC END# *51DECB820261_51DED02E0163_impl*
end;//IsSame
 
type _List_R_ = _UnrefcountedListPrim_;
 
{$Include List.imp.pas}
 
 
{$EndIf UnrefcountedListPrim_imp}

AtomicList.imp.pas:

{$IfNDef AtomicList_imp}
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBox"
// The unit: "AtomicList.imp.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: Impurity::Class Shared Delphi Sand Box::SandBox::STLLike::AtomicList
//
// The list of atomic values
//
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
{$Define AtomicList_imp}
 {$Define l3Items_IsAtomic}
 
 _UnrefcountedListPrim_Parent_ = _AtomicList_Parent_;
 {$Include UnrefcountedListPrim.imp.pas}
 _AtomicList_ = {mixin} class(_UnrefcountedListPrim_)
  {* The list of atomic values }
 end;//_AtomicList_
 
{$Else AtomicList_imp}
 
// start class _AtomicList_
 
procedure FillItem(var thePlace: _ItemType_;
  const aFrom: _ItemType_); forward;
 
procedure FreeItem(var thePlace: _ItemType_);
//#UC START# *51DEC20B01D7_51DED48301D9_var*
//#UC END# *51DEC20B01D7_51DED48301D9_var*
begin
//#UC START# *51DEC20B01D7_51DED48301D9_impl*
 thePlace := _ItemType_(0);
//#UC END# *51DEC20B01D7_51DED48301D9_impl*
end;//FreeItem
 
procedure FillItem(var thePlace: _ItemType_;
  const aFrom: _ItemType_);
//#UC START# *51DECB440087_51DED48301D9_var*
//#UC END# *51DECB440087_51DED48301D9_var*
begin
//#UC START# *51DECB440087_51DED48301D9_impl*
 thePlace := aFrom;
//#UC END# *51DECB440087_51DED48301D9_impl*
end;//FillItem
 
type _UnrefcountedListPrim_R_ = _AtomicList_;
 
{$Include UnrefcountedListPrim.imp.pas}
 
 
{$EndIf AtomicList_imp}


The code is here - http://sourceforge.net/p/rumtmarc/code-0/19/tree/trunk/Blogger/SandBox and http://sourceforge.net/p/rumtmarc/code-0/19/tree/trunk/Blogger/SandBoxTest

Containers 5. Encapsulation of the work with the memory. Part 1

Original in Russian: http://18delphi.blogspot.ru/2013/07/1.html

About containers. Table of contents

Now we shall allocate the work with the memory to a separate object - Tl3PtrLoc.

The model:


The code:

l3MemUtils.pas:

unit l3MemUtils;
 
//
// The library "L3$Basic Concepts"
// Generated from UML model, root element: SimpleClass::Class Shared Delphi Requirements to the low-level libraries::L3$Basic Concepts::MemoryUtils::Tl3MemUtils
//
 
interface
 
uses
  Refcounted
  ;
 
type
 Rl3MemUtils = class of Tl3MemUtils;
 
 Tl3MemUtils = class(TRefcounted)
 protected
 // protected methods
   class procedure CheckMaxes; virtual;
     {* The signature of the method CheckMaxes }
   class procedure StatMemAlloc(aSize: Integer;
     aL3: Boolean); virtual;
 public
 // public methods
   class procedure ReallocLocalMem(var P;
     NewSize: Cardinal);
     {* reallocate the piece of the local memory }
   class procedure FreeLocalMem(var P);
     {* free the piece of the local memory }
 end;//Tl3MemUtils
 
var
   l3MemU : Rl3MemUtils = Tl3MemUtils;
var
   f_LocalMemUsed : Integer;
 
implementation
 
uses
  l3MemorySizeUtils
  ;
 
// start class Tl3MemUtils
 
class procedure Tl3MemUtils.ReallocLocalMem(var P;
  NewSize: Cardinal);
//#UC START# *51DD561502D9_51DD554C0205_var*
//#UC END# *51DD561502D9_51DD554C0205_var*
begin
//#UC START# *51DD561502D9_51DD554C0205_impl*
 Dec(f_LocalMemUsed, l3MemorySize(Pointer(P)));
 {$IfDef l3DirectUseSystemMemManager}
 if (Pointer(P) = nil) then
 begin
  l3MemU.StatMemAlloc(NewSize, true);
  Pointer(P) := SysGetMem(NewSize)
 end//Pointer(P) = nil
 else
 if (NewSize > 0) then
 begin
  l3MemU.StatMemAlloc(NewSize, true);
  Pointer(P) := SysReallocMem(Pointer(P), NewSize);
 end//NewSize > 0
 else
 begin
  SysFreeMem(Pointer(P));
  Pointer(P) := nil;
 end;//NewSize > 0
 {$Else  l3DirectUseSystemMemManager}
  System.ReallocMem(Pointer(P), NewSize);
 {$EndIf l3DirectUseSystemMemManager}
 Inc(f_LocalMemUsed, l3MemorySize(Pointer(P)));
 l3MemU.CheckMaxes;
//#UC END# *51DD561502D9_51DD554C0205_impl*
end;//Tl3MemUtils.ReallocLocalMem
 
class procedure Tl3MemUtils.FreeLocalMem(var P);
//#UC START# *51DD62110253_51DD554C0205_var*
//#UC END# *51DD62110253_51DD554C0205_var*
begin
//#UC START# *51DD62110253_51DD554C0205_impl*
 if (Pointer(P) <> nil) then
 begin
  Dec(f_LocalMemUsed, l3MemorySize(Pointer(P)));
  {$IfDef l3DirectUseSystemMemManager}
  SysFreeMem(Pointer(P));
  {$Else  l3DirectUseSystemMemManager}
  System.FreeMem(Pointer(P));
  {$EndIf l3DirectUseSystemMemManager}
 end;//Pointer(P) <> nil
 Pointer(P) := nil;
//#UC END# *51DD62110253_51DD554C0205_impl*
end;//Tl3MemUtils.FreeLocalMem
 
class procedure Tl3MemUtils.CheckMaxes;
//#UC START# *51DD686A03A3_51DD554C0205_var*
//#UC END# *51DD686A03A3_51DD554C0205_var*
begin
//#UC START# *51DD686A03A3_51DD554C0205_impl*
 // - for now we do nothing
//#UC END# *51DD686A03A3_51DD554C0205_impl*
end;//Tl3MemUtils.CheckMaxes
 
class procedure Tl3MemUtils.StatMemAlloc(aSize: Integer;
  aL3: Boolean);
//#UC START# *51DD6DCE00DF_51DD554C0205_var*
//#UC END# *51DD6DCE00DF_51DD554C0205_var*
begin
//#UC START# *51DD6DCE00DF_51DD554C0205_impl*
 // - or now we do nothing
//#UC END# *51DD6DCE00DF_51DD554C0205_impl*
end;//Tl3MemUtils.StatMemAlloc
 
end.

l3PtrLoc.pas:

unit l3PtrLoc;
 
//
// The library "L3$Basic Concepts"
// Generated from UML model, root element: UtilityPack::Class Shared Delphi Requirements to the low-level libraries::L3$Basic Concepts::MemoryUtils::l3PtrLoc
//
 
interface
 
uses
  l3MemorySizeUtils
  ;
 
type
 Tl3PtrLoc = {$IfDef XE4}record{$Else}object{$EndIf}
 private
   f_AsPointer : PMem;
 public
    function Init(aSize: Integer): Boolean;
    function GetSize: Integer;
    procedure SetSize(aSize: Integer);
    procedure Clear;
    function Read(anOfs: Integer;
     aBuf: PMem;
     aBufSize: Integer): Integer;
    function Write(anOfs: Integer;
     aBuf: PMem;
     aBufSize: Integer): Integer;
  public
   property AsPointer: PMem
     read f_AsPointer;
 end;//Tl3PtrLoc
 
implementation
 
uses
  l3MemUtils
  ;
 
// start class Tl3PtrLoc
 
function Tl3PtrLoc.Init(aSize: Integer): Boolean;
//#UC START# *51DD5D1903C3_51DD567A01B5_var*
//#UC END# *51DD5D1903C3_51DD567A01B5_var*
begin
//#UC START# *51DD5D1903C3_51DD567A01B5_impl*
 f_AsPointer := nil;
 SetSize(aSize);
 Result := (f_AsPointer <> nil);
//#UC END# *51DD5D1903C3_51DD567A01B5_impl*
end;//Tl3PtrLoc.Init
 
function Tl3PtrLoc.GetSize: Integer;
//#UC START# *51DD5D3800F3_51DD567A01B5_var*
//#UC END# *51DD5D3800F3_51DD567A01B5_var*
begin
//#UC START# *51DD5D3800F3_51DD567A01B5_impl*
 Result := l3MemorySize(f_AsPointer);
//#UC END# *51DD5D3800F3_51DD567A01B5_impl*
end;//Tl3PtrLoc.GetSize
 
procedure Tl3PtrLoc.SetSize(aSize: Integer);
//#UC START# *51DD5D4F004A_51DD567A01B5_var*
//#UC END# *51DD5D4F004A_51DD567A01B5_var*
begin
//#UC START# *51DD5D4F004A_51DD567A01B5_impl*
 if (aSize = 0) then
  l3MemU.FreeLocalMem(f_AsPointer)
 else
 if (GetSize < aSize) then
 begin
  // - previously it was <> - now I’ve decided to try not to reduce the size of the memory
  //   so that not to produce defragmentation.
  if (aSize < 10) then
   l3MemU.ReallocLocalMem(f_AsPointer, aSize)
  else
   l3MemU.ReallocLocalMem(f_AsPointer, (aSize + $F) and $FFFFFFF0);
 end;//GetSize < aSize
//#UC END# *51DD5D4F004A_51DD567A01B5_impl*
end;//Tl3PtrLoc.SetSize
 
procedure Tl3PtrLoc.Clear;
//#UC START# *51DD5D6F0304_51DD567A01B5_var*
//#UC END# *51DD5D6F0304_51DD567A01B5_var*
begin
//#UC START# *51DD5D6F0304_51DD567A01B5_impl*
 SetSize(0);
//#UC END# *51DD5D6F0304_51DD567A01B5_impl*
end;//Tl3PtrLoc.Clear
 
function Tl3PtrLoc.Read(anOfs: Integer;
  aBuf: PMem;
  aBufSize: Integer): Integer;
//#UC START# *51DD5E2203B0_51DD567A01B5_var*
//#UC END# *51DD5E2203B0_51DD567A01B5_var*
begin
//#UC START# *51DD5E2203B0_51DD567A01B5_impl*
 Result := 0;
 Assert(false, 'Not implemented yet');
(* Result := Min(GetSize - anOfs, aBufSize);
 if (Result > 0) then
  l3Move((P + anOfs)^, aBuf^, Result)
 else
  Result := 0;*)
//#UC END# *51DD5E2203B0_51DD567A01B5_impl*
end;//Tl3PtrLoc.Read
 
function Tl3PtrLoc.Write(anOfs: Integer;
  aBuf: PMem;
  aBufSize: Integer): Integer;
//#UC START# *51DD5E5F02E1_51DD567A01B5_var*
(*var
 OldSize : Integer;
 NewSize : Integer;*)
//#UC END# *51DD5E5F02E1_51DD567A01B5_var*
begin
//#UC START# *51DD5E5F02E1_51DD567A01B5_impl*
 Result := 0;
 Assert(false, 'Not implemented yet');
(* OldSize := GetSize;
 NewSize := Ofs + BufSize;
 if (NewSize > OldSize) then SetSize(NewSize);
 Result := BufSize;
 l3Move(Buf^, (P + Ofs)^, Result);*)
//#UC END# *51DD5E5F02E1_51DD567A01B5_impl*
end;//Tl3PtrLoc.Write
 
end.

The source code - https://sourceforge.net/p/rumtmarc/code-0/17/tree/trunk/Blogger/STL.2/

Containers 4. Encapsulation of the work with the memory. Part 0

Original in Russian: http://18delphi.blogspot.ru/2013/07/0.html

About containers. Table of contents

I’d like to continue describing the containers in “STL style”.

Tthere I have used dynamic arrays.

In my REAL “micro-STL” I use direct work with the memory - GetMem/FreeMem.

That is why I want to start with how I work with the memory directly. Or rather how I’ve encapsulated the work with the memory in different facade functions/objects.

The first example is receiving the size of the memory piece. I have already told a bit here - http://18delphi.blogspot.ru/2015/02/how-to-find-out-true-size-of-memory.html

And now I want to show how it is drawn on UML and how it is encapsulated in a separate unit.

So.

At first – the model:


And the code:


l3MemorySizeUtilsPrim.pas:
unit l3MemorySizeUtilsPrim;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "L3$Basic Concepts"
// The unit: "w:/common/components/rtl/L3/l3MemorySizeUtilsPrim.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: UtilityPack::Class Shared Delphi Requirements to the low-level libraries::L3$Basic Concepts::MemoryUtils::l3MemorySizeUtilsPrim
//
//
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
// ! Fully generated from the model. It is not allowed to edit manually. !
 
interface
 
type
 Tl3MemorySizeFunc = function (aPtr: Pointer): Integer;
 {$If not defined(XE)}
function L3MemorySizeDelphi7(aPtr: Pointer): Integer;
   {* function to get the size of the memory piece }
 {$IfEnd} //not XE
 {$If defined(XE)}
function L3MemorySizeXE(aPtr: Pointer): Integer;
   {* function to get the size of the memory piece }
 {$IfEnd} //XE
 
implementation
 
uses
  l3MemorySizeUtils
  ;
 
// unit methods
 
{$If not defined(XE)}
function L3MemorySizeDelphi7(aPtr: Pointer): Integer;
//#UC START# *51DAD8DC00B2_51DADE55035E_var*
const
  cThisUsedFlag = 2;
  cPrevFreeFlag = 1;
  cFillerFlag   = Integer($80000000);
  cFlags        = cThisUsedFlag or cPrevFreeFlag or cFillerFlag;
 
type
  PUsed = ^TUsed;
  TUsed = packed record
    sizeFlags: Integer;
  end;//TUsed
 
//#UC END# *51DAD8DC00B2_51DADE55035E_var*
begin
//#UC START# *51DAD8DC00B2_51DADE55035E_impl*
 if (aPtr = nil) then
  Result := 0
 else
  Result := PUsed(PMem(aPtr)-SizeOf(TUsed)).sizeFlags and not cFlags - sizeof(TUsed);
//  Result := (PLong(Long(aP) - 4)^ AND not cFlags) - 4;
//#UC END# *51DAD8DC00B2_51DADE55035E_impl*
end;//L3MemorySizeDelphi7
{$IfEnd} //not XE
 
{$If defined(XE)}
function L3MemorySizeXE(aPtr: Pointer): Integer;
//#UC START# *51DADA9600F9_51DADE55035E_var*
 
const
  {----------------------------Block type flags---------------------------}
  {The lower 3 bits in the dword header of small blocks (4 bits in medium and
   large blocks) are used as flags to indicate the state of the block}
  {Set if the block is not in use}
  IsFreeBlockFlag = 1;
  {Set if this is a medium block}
  IsMediumBlockFlag = 2;
  {Set if it is a medium block being used as a small block pool. Only valid if
   IsMediumBlockFlag is set.}
  IsSmallBlockPoolInUseFlag = 4;
  {Set if it is a large block. Only valid if IsMediumBlockFlag is not set.}
  IsLargeBlockFlag = 4;
  {Is the medium block preceding this block available?}
  PreviousMediumBlockIsFreeFlag = 8;
  {Is this large block segmented? I.e. is it actually built up from more than
   one chunk allocated through VirtualAlloc? (Only used by large blocks.)}
  LargeBlockIsSegmented = 8;
  {The flags masks for small blocks}
  DropSmallFlagsMask = -8;
  ExtractSmallFlagsMask = 7;
  {The flags masks for medium and large blocks}
  DropMediumAndLargeFlagsMask = -16;
  ExtractMediumAndLargeFlagsMask = 15;
{------------------------------Private types------------------------------}
type
  
  {Move procedure type}
  TMoveProc = procedure(const ASource; var ADest; ACount: NativeInt);
  
  {-----------------------Small block structures--------------------------}
  
  {Pointer to the header of a small block pool}
  PSmallBlockPoolHeader = ^TSmallBlockPoolHeader;
  
  {Small block type (Size = 32 bytes for 32-bit, 64 bytes for 64-bit).}
  PSmallBlockType = ^TSmallBlockType;
  TSmallBlockType = record
    {True = Block type is locked}
    BlockTypeLocked: Boolean;
    {Bitmap indicating which of the first 8 medium block groups contain blocks
     of a suitable size for a block pool.}
    AllowedGroupsForBlockPoolBitmap: Byte;
    {The block size for this block type}
    BlockSize: Word;
    {The minimum and optimal size of a small block pool for this block type}
    MinimumBlockPoolSize: Word;
    OptimalBlockPoolSize: Word;
    {The first partially free pool for the given small block. This field must
     be at the same offset as TSmallBlockPoolHeader.NextPartiallyFreePool.}
    NextPartiallyFreePool: PSmallBlockPoolHeader;
    {The last partially free pool for the small block type. This field must
     be at the same offset as TSmallBlockPoolHeader.PreviousPartiallyFreePool.}
    PreviousPartiallyFreePool: PSmallBlockPoolHeader;
    {The offset of the last block that was served sequentially. The field must
     be at the same offset as TSmallBlockPoolHeader.FirstFreeBlock.}
    NextSequentialFeedBlockAddress: Pointer;
    {The last block that can be served sequentially.}
    MaxSequentialFeedBlockAddress: Pointer;
    {The pool that is current being used to serve blocks in sequential order}
    CurrentSequentialFeedPool: PSmallBlockPoolHeader;
{$ifdef UseCustomFixedSizeMoveRoutines}
    {The fixed size move procedure used to move data for this block size when
     it is upsized. When a block is downsized (which usually does not occur
     that often) the variable size move routine is used.}
    UpsizeMoveProcedure: TMoveProc;
{$else}
    Reserved1: Pointer;
{$endif}
{$if SizeOf(Pointer) = 8}
    {Pad to 64 bytes for 64-bit}
    Reserved2: Pointer;
{$ifend}
  end;
  
  {Small block pool (Size = 32 bytes for 32-bit, 48 bytes for 64-bit).}
  TSmallBlockPoolHeader = record
    {BlockType}
    BlockType: PSmallBlockType;
{$if SizeOf(Pointer) <> 8}
    {Align the next fields to the same fields in TSmallBlockType and pad this
     structure to 32 bytes for 32-bit}
    Reserved1: Cardinal;
{$ifend}
    {The next and previous pool that has free blocks of this size. Do not
     change the position of these two fields: They must be at the same offsets
     as the fields in TSmallBlockType of the same name.}
    NextPartiallyFreePool: PSmallBlockPoolHeader;
    PreviousPartiallyFreePool: PSmallBlockPoolHeader;
    {Pointer to the first free block inside this pool. This field must be at
     the same offset as TSmallBlockType.NextSequentialFeedBlockAddress.}
    FirstFreeBlock: Pointer;
    {The number of blocks allocated in this pool.}
    BlocksInUse: Cardinal;
    {Small block pool signature. Used by the leak checking mechanism to
     determine whether a medium block is a small block pool or a regular medium
     block.}
    SmallBlockPoolSignature: Cardinal;
    {The pool pointer and flags of the first block}
    FirstBlockPoolPointerAndFlags: NativeUInt;
  end;
  
  {Small block layout:
   At offset -SizeOf(Pointer) = Flags + address of the small block pool.
   At offset BlockSize - SizeOf(Pointer) = Flags + address of the small block
   pool for the next small block.
  }
  
  {------------------------Medium block structures------------------------}
  
  {The medium block pool from which medium blocks are drawn. Size = 16 bytes
   for 32-bit and 32 bytes for 64-bit.}
  PMediumBlockPoolHeader = ^TMediumBlockPoolHeader;
  TMediumBlockPoolHeader = record
    {Points to the previous and next medium block pools. This circular linked
     list is used to track memory leaks on program shutdown.}
    PreviousMediumBlockPoolHeader: PMediumBlockPoolHeader;
    NextMediumBlockPoolHeader: PMediumBlockPoolHeader;
    {Padding}
    Reserved1: NativeUInt;
    {The block size and flags of the first medium block in the block pool}
    FirstMediumBlockSizeAndFlags: NativeUInt;
  end;
  
  {Medium block layout:
   Offset: -2 * SizeOf(Pointer) = Previous Block Size (only if the previous block is free)
   Offset: -SizeOf(Pointer) = This block size and flags
   Offset: 0 = User data / Previous Free Block (if this block is free)
   Offset: SizeOf(Pointer) = Next Free Block (if this block is free)
   Offset: BlockSize - 2*SizeOf(Pointer) = Size of this block (if this block is free)
   Offset: BlockSize - SizeOf(Pointer) = Size of the next block and flags
  
  {A medium block that is unused}
  PMediumFreeBlock = ^TMediumFreeBlock;
  TMediumFreeBlock = record
    PreviousFreeBlock: PMediumFreeBlock;
    NextFreeBlock: PMediumFreeBlock;
  end;
  
  {-------------------------Large block structures------------------------}
  
  {Large block header record (Size = 16 for 32-bit, 32 for 64-bit)}
  PLargeBlockHeader = ^TLargeBlockHeader;
  TLargeBlockHeader = record
    {Points to the previous and next large blocks. This circular linked
     list is used to track memory leaks on program shutdown.}
    PreviousLargeBlockHeader: PLargeBlockHeader;
    NextLargeBlockHeader: PLargeBlockHeader;
    {The user allocated size of the Large block}
    UserAllocatedSize: NativeUInt;
    {The size of this block plus the flags}
    BlockSizeAndFlags: NativeUInt;
  end; 
 
{---------------------------Private constants-----------------------------}
const
  {The size of the block header in front of small and medium blocks}
  BlockHeaderSize = SizeOf(Pointer);
  {The size of a small block pool header}
  SmallBlockPoolHeaderSize = SizeOf(TSmallBlockPoolHeader);
  {The size of a medium block pool header}
  MediumBlockPoolHeaderSize = SizeOf(TMediumBlockPoolHeader);
  {The size of the header in front of Large blocks}
  LargeBlockHeaderSize = SizeOf(TLargeBlockHeader);
  (*
  {This memory manager}
  ThisMemoryManager: TMemoryManagerEx = (
    GetMem: SysGetMem;
    FreeMem: SysFreeMem;
    ReallocMem: SysReallocMem;
    AllocMem: SysAllocMem;
    RegisterExpectedMemoryLeak: SysRegisterExpectedMemoryLeak;
    UnregisterExpectedMemoryLeak: SysUnregisterExpectedMemoryLeak);
   *)
    
var
 lBlockHeader: Cardinal;
 LPSmallBlockType: PSmallBlockType;
 LOldAvailableSize: Cardinal;
//#UC END# *51DADA9600F9_51DADE55035E_var*
begin
//#UC START# *51DADA9600F9_51DADE55035E_impl*
 if (aPtr = nil) then
   Result := 0
 else
 begin
 {Get the block header: Is it actually a small block?}
   LBlockHeader := PNativeUInt(PByte(aPtr) - BlockHeaderSize)^;
   {Is it a small block that is in use?}
   if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then
   begin
     {----------------------------Small block------------------------------}
     {The block header is a pointer to the block pool: Get the block type}
     LPSmallBlockType := PSmallBlockPoolHeader(LBlockHeader).BlockType;
     {Get the available size inside blocks of this type.}
     Result := LPSmallBlockType.BlockSize - BlockHeaderSize;
   end
   else
   begin
     {Is this a medium block or a large block?}
     if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then
     begin
      Result:= (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize;
     end
     else
     begin
       {Is this a valid large block?}
       if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then
       begin
         {-----------------------Large block------------------------------}
         {Get the block header}
         //LBlockHeader := PNativeUInt(PByte(aP) - BlockHeaderSize)^;
         {Subtract the overhead to determine the useable size in the large block.}
         Result := (LBlockHeader and DropMediumAndLargeFlagsMask) - (LargeBlockHeaderSize + BlockHeaderSize);
       end
       else
       begin
         {-----------------------Invalid block------------------------------}
         {Bad pointer: probably an attempt to reallocate a free memory block.}
         Result := 0;
         assert(false);
       end;
     end;
   end;
 end;
//#UC END# *51DADA9600F9_51DADE55035E_impl*
end;//L3MemorySizeXE
{$IfEnd} //XE
 
end.

------
l3MemorySizeUtils.pas:
unit l3MemorySizeUtils;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "L3$Basic Concepts"
// The unit: "w:/common/components/rtl/L3/l3MemorySizeUtils.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: UtilityPack::Class Shared Delphi Requirements to the low-level libraries::L3$Basic Concepts::MemoryUtils::l3MemorySizeUtils
//
//
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
// ! Fully generated from the model. It is not allowed to edit manually. !
 
interface
 
uses
  l3MemorySizeUtilsPrim
  ;
 
type
 PMem = System.PANSIChar;
 
{$If not defined(XE)}
var l3MemorySize : Tl3MemorySizeFunc = L3MemorySizeDelphi7;
 {* function to get the size of the memory piece}
{$IfEnd} //not XE
 
{$If defined(XE)}
var l3MemorySize : Tl3MemorySizeFunc = L3MemorySizeXE;
 {* function to get the size of the memory piece}
{$IfEnd} //XE
 
implementation
 
end.

And the test.

The model:

The code:

unit MemorySizeTest;
 
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//
// The library "SandBoxTest"
// The unit: "w:/common/components/rtl/SandBox/MemorySizeTest.pas"
// Native Delphi interfaces (.pas)
// Generated from UML model, root element: TestCase::Class Shared Delphi Sand Box::SandBoxTest::Memory::MemorySizeTest
//
//
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
// ! Fully generated from the model. It is not allowed to edit manually. !
 
interface
 
{$If defined(nsTest)}
uses
  BaseTest
  ;
{$IfEnd} //nsTest
 
{$If defined(nsTest)}
type
 TMemorySizeTest = class(TBaseTest)
 protected
 // overridden protected methods
   function GetFolder: AnsiString; override;
     {* The folder containing the test }
   function GetModelElementGUID: AnsiString; override;
     {* The model element identifier that describes the test }
 published
 // published methods
   procedure DoIt;
 end;//TMemorySizeTest
{$IfEnd} //nsTest
 
implementation
 
{$If defined(nsTest)}
uses
  l3MemorySizeUtils,
  SysUtils,
  TestFrameWork
  ;
{$IfEnd} //nsTest
 
{$If defined(nsTest)}
 
// start class TMemorySizeTest
 
procedure TMemorySizeTest.DoIt;
//#UC START# *51DAE7030012_51DAE6E20300_var*
var
 l_Index : Integer;
 l_Size  : Integer;
 l_RealSize : Integer;
 l_P     : Pointer;
//#UC END# *51DAE7030012_51DAE6E20300_var*
begin
//#UC START# *51DAE7030012_51DAE6E20300_impl*
 for l_Index := 1 to 4 * 1024 do
 begin
  l_Size := l_Index * 2;
  System.GetMem(l_P, l_Size);
  try
   l_RealSize := l3MemorySize(l_P);
   Check(l_RealSize >= l_Size, Format('We have allocated %d. It has been allocated %d.', [l_Size, l_RealSize]));
  finally
   System.FreeMem(l_P);
  end;//try..finally
 end;//form l_Index
//#UC END# *51DAE7030012_51DAE6E20300_impl*
end;//TMemorySizeTest.DoIt
 
function TMemorySizeTest.GetFolder: AnsiString;
 {-}
begin
 Result := 'Memory';
end;//TMemorySizeTest.GetFolder
 
function TMemorySizeTest.GetModelElementGUID: AnsiString;
 {-}
begin
 Result := '51DAE6E20300';
end;//TMemorySizeTest.GetModelElementGUID
 
{$IfEnd} //nsTest
 
initialization
 TestFramework.RegisterTest(TMemorySizeTest.Suite);
 
end.

Next, I hope, I’ll tell about the encapsulation GetMem/FreeMem/ReallocMem in "object" Tl3Ptr.

All sources are here - https://sourceforge.net/p/rumtmarc/code-0/15/tree/trunk/Blogger/STL.1/