Base Classes, Testing, and More

Base Classes
Now that we've written our first classes, it is time to take a look at the larger framework under which we are developing the various pieces of UOS. Most classes, including the main UOS components need to be emancipated and need to support exception handling. But rather than including this support in each class by copying the code and instance data, it makes more sense to create a base class from which all of our classes descend. Here is the abstract base class:

type TBase_COM_Interface = class
                               public { API... }
                                   { Initialize the object.  Returns result of
                                     initialization attempt. }
                                   function Initialize : TUnified_Exception ;
                                       virtual ; stdcall ; abstract ;

                                   { Terminate the use of the object.  Returns
                                     result of termination.  This generally
                                     should not be used - instead, use the
                                     Detach method. }
                                   function Terminate : TUnified_Exception ;
                                       virtual ; stdcall ; abstract ;

                                   { Increments the reference count for the
                                     object. }
                                   procedure Attach ; virtual ;
                                       stdcall ; abstract ;

                                   { Decrements the reference count for the
                                     object.  When count reaches 0, the object
                                     is destroyed. }
                                   procedure Detach ; virtual ;
                                       stdcall ; abstract ;

                                   { Returns True if this class is the passed
                                     class name. }
                                   function Is_Class( Name : PChar ) : boolean ;
                                       virtual ; stdcall ; abstract ;

                                   { Version of the COM interface for this
                                     object. }
                                   function Interface_Version : longint ;
                                       virtual ; stdcall ; abstract ;

                                   { Facility ID for the facility represented
                                     by this object.  Returns -1 if no
                                     facility assigned. }
                                   function Facility_ID : longint ; virtual ;
                                       stdcall ; abstract ;

                                   { Facility version.  Result only has
                                     meaning if Facility_ID doesn't return
                                     -1. }
                                   function Facility_Version : longint ;
                                       virtual ; stdcall ; abstract ;

                                   { Returns a debugging interface for the
                                     object.  Returns nil if not supported. }
                                   function Debugger : TDebug_Interface ;
                                       virtual ; stdcall ; abstract ;

                                   { Returns last error. }
                                   function Last_Error : TUnified_Exception ;
                                       virtual ; stdcall ; abstract ;

                                   { Returns a pointer to an object with
                                     extended common COM methods for object.
                                     Always returns nil for now. }
                                   function Extension : pointer ; virtual ;
                                       stdcall ; abstract ;
                           end ; { TBase_COM_Interface }

We use this abstract base class for all our UOS objects. We've already discussed Attach and Detach. Initialize is used to (re)initialize the object after it is constructed, and Terminate is used to free the instance. In our case, our constructor does all the initialization and there is no need to reinitialize the instance, so our Initialize does nothing and our Terminate just calls Free. Note: Terminate should only be called from Detach. Interface_Version is used to indicate the version of the TBase_COM_Interface class. This is intended for use in the future, if we make significant changes to the class, for backwards compatibility. For our purposes, we ignore this. Facility_ID is a numeric value that uniquely identifies our class (more on this in a later article). Facility_Version indicates the version of our class (times 10). Thus, we will return 10, which means we are V1.0 of our class. Debugger returns a debugging interface for our class. This is intended for run-time debugging. For now, we will return nil to indicate that we don't support that feature. Finally, Extension is to allow us to extend the base class capabilities, without requiring a complete build of code that uses it when we do. Is_Class is a way to query the class name. Which we will ignore for now. It may seem like a lot, but we are still only really interested in Attach, Detach, and Facility_Version.

It would be annoying to have to include overrides for all of these methods - especially since they do the same thing in every class, for the most part. So, we have a descendant of this class that includes all the default behavior. Then we only have to override what is different for our class (in our case, this is only the Facility_Version):

type TCommon_COM_Interface = class( TBase_COM_Interface )
                                 private { Instance data... }
                                     Reference_Count : longint ;
                                     _Last_Error : TUnified_Exception ;

                                 public { API... }
                                     { Initialize the object.  Returns result of
                                       initialization attempt. }
                                     function Initialize : TUnified_Exception ;
                                         override ; stdcall ;

                                     { Terminate the use of the object.  Returns
                                       result of termination.  This generally
                                       should not be used - instead, use the
                                       Detach method. }
                                     function Terminate : TUnified_Exception ;
                                         override ; stdcall ;

                                     { Increments the reference count for the
                                       object. }
                                     procedure Attach ; override ; stdcall ;

                                     { Decrements the reference count for the
                                       object.  When count reaches 0, the object
                                       is destroyed. }
                                     procedure Detach ;
                                         override ; stdcall ;

                                     { Version of the COM interface for this
                                       object. }
                                     function Interface_Version : longint ;
                                         override ; stdcall ;

                                     { Facility ID for the facility represented
                                       by this object.  Returns -1 if no
                                       facility assigned. }
                                     function Facility_ID : longint ;
                                         override ; stdcall ;

                                     { Facility version.  Result only has
                                       meaning if Facility_ID doesn't return
                                       -1. }
                                     function Facility_Version : longint ;
                                         override ; stdcall ;

                                     { Returns a debugging interface for the
                                       object.  Returns nil if not supported. }
                                     function Debugger : TDebug_Interface ;
                                         override ; stdcall ;

                                     { Returns last error. }
                                     function Last_Error : TUnified_Exception ;
                                         override ; stdcall ;

                                     { Returns a pointer to an object with
                                       extended common COM methods for object.
                                       Always returns nil for now. }
                                     function Extension : pointer ; override ;
                                         stdcall ;

                                 protected // Internal utility routines...
                                     { Note: Don't make any of these virtual, as
                                       that could mess up VMT layout.  This class
                                       is simply to provide implementation of
                                       the abstract base class. }
                                     procedure Set_Last_Error( E : TUnified_Exception ) ;
                             end ; { TCommon_COM_Interface }

function TCommon_COM_Interface.Initialize : TUnified_Exception ; stdcall ;

begin
    Result := nil ;
    Reference_Count := 0 ;
end ;


function TCommon_COM_Interface.Terminate : TUnified_Exception ; stdcall ;

begin
    Result := nil ;
    Free ;
end ;


procedure TCommon_COM_Interface.Attach ; stdcall ;

begin
    inc( Reference_Count ) ;
end ;


procedure TCommon_COM_Interface.Detach ; stdcall ;

begin
    dec( Reference_Count ) ;
    if( Reference_Count < 1 ) then
    begin
        Terminate ;
    end ;
end ;


function TCommon_COM_Interface.Interface_Version : longint ; stdcall ;

begin
    Interface_Version := 0 ;
end ;


function TCommon_COM_Interface.Facility_ID : longint ; stdcall ;

begin
    Facility_ID := -1 ;
end ;


function TCommon_COM_Interface.Facility_Version : longint ; stdcall ;

begin
    Facility_Version := 0 ;
end ;


function TCommon_COM_Interface.Debugger : TDebug_Interface ; stdcall ;

begin
    Debugger := nil ;
end ;


function TCommon_COM_Interface.Extension : pointer ; stdcall ;

begin
    Extension := nil ;
end ;


// Internal utility routines...

procedure TCommon_COM_Interface.Set_Last_Error( E : TUnified_Exception ) ;

begin
    if( E <> nil ) then
    begin
        E.Attach ;
    end ;
    if( _Last_Error <> nil ) then
    begin
        _Last_Error.Detach ;
    end ;
    _Last_Error := E ;
end ;

We'll keep these in the COMInter unit, and descend our class from TCommon_COM_Interface. In fact, we will descend all of our classes from this base class. Since the base class handles the attach, detach, and Set_Last_Error, we can drop those from our class.

TUnified_Exception is the one exception to descending all things from the base class. That is because the base class references this class and we don't want to create a circular reference. As a consequence the class definition is very similar to TBase_COM_Interface. Here is the actual base class:

type tUnified_Exception = class
                            public
                                function Initialize : TUnified_Exception ;
                                    virtual ; stdcall ; abstract ;
                                procedure Terminate ; virtual ;
                                    stdcall ; abstract ;
                                procedure Attach ;
                                    virtual ; stdcall ; abstract ;
                                procedure Detach ;
                                    virtual ; stdcall ; abstract ;
                                function Is_Class( Name : PChar ) : boolean ;
                                    virtual ; stdcall ; abstract ;
                                function Interface_Version : longint ;
                                    virtual ; stdcall ; abstract ;
                                function Get_Facility : longint ; virtual ;
                                    stdcall ; abstract ;
                                function Get_Facility_Version : longint ;
                                    virtual ; stdcall ; abstract ;
                                function Version : longint ; virtual ;
                                    stdcall ; abstract ;
                                function Debugger : TDebug_Interface ;
                                    virtual ; stdcall ; abstract ;
                                function Severity : longint ; virtual ;
                                    stdcall ; abstract ;
                                function Error_Text( var Size, Typ : longint ) : PChar ;
                                    virtual ; stdcall ; abstract ;
                                function Get_Error : longint ; virtual ;
                                    stdcall ; abstract ;
                                function Get_Previous : tUnified_Exception ;
                                    virtual ; stdcall ; abstract ;
                        end ;

As in the previous case, rather than have each descendant class implement attach, detach, et al, we will descend from a class that implements default methods. Here it is:

type TStandard_Error_Interface = class( tUnified_Exception )
                                     private
                                         _Reference_Count : integer ;
                                         _Additional_Text : string ;
                                         Temp : string ;

                                     public
                                         function Initialize : TUnified_Exception ;
                                             override ;
                                         procedure Terminate ; override ;
                                         procedure Attach ; override ;
                                         procedure Detach ; override ;
                                         function Is_Class( Name : PChar ) : boolean ;
                                             override ;
                                         function Interface_Version : longint ;
                                             override ;
                                         function Get_Facility : longint ;
                                             override ;
                                         function Get_Facility_Version : longint ;
                                             override ;
                                         function Version : longint ; override ;
                                         function Debugger : TDebug_Interface ;
                                             override ;
                                         function Severity : longint ;
                                             override ;
                                         function Error_Text( var Size, Typ : longint ) : PChar ;
                                             override ;
                                         function Get_Error : longint ;
                                             override ;
                                         function Get_Previous : tUnified_Exception ;
                                             override ;
                                 end ; { TStandard_Error_Interface }

function TSStandard_Error_Interface.Get_Facility : longint ;

begin
    Get_Facility := -1 ;
end ;


function TSStandard_Error_Interface.Get_Facility_Version : longint ;

begin
    Get_Facility_Version := 0 ;
end ;


function TSStandard_Error_Interface.Severity : longint ;

begin
    Severity := UE_Error ;
end ;


function TSStandard_Error_Interface.Error_Text( var Size, Typ : longint ) : string ;

var P : string ;

begin
    P := '' ;
    Size := length( P ) ;
    Typ := 0 ; { 7-bit ASCII }
    Error_Text := P ;
end ;


function TSStandard_Error_Interface.Get_Error : longint ;

begin
    Get_Error := 0 ;
end ;


function TSStandard_Error_Interface.Get_Previous : psUnified_Exception ;

begin
    Get_Previous := nil ;
end ;


procedure TSStandard_Error_Interface.Terminate ;

begin
    if( Get_Previous <> nil ) then
    begin
        Get_Previous.Free ;
    end ;
end ;


procedure TSStandard_Error_Interface.Set_Memory_Type( MT : TMemory_Type ) ;

begin
    _Memory_Type := MT ;
end ;


function TSStandard_Error_Interface.Get_Memory_Type : TMemory_Type ;

begin
    Get_Memory_Type := _Memory_Type ;
end ;

Testing
The subject of code testing is a large one and we won't go into gory detail here. But, since it is essential to be able to rely upon the operating system code, we need to be rigorous in our development. I have implemented a three-level certification process for the code. Level 1 is what we call a functional test. The purpose is to test each functional aspect of the code. In this class, it is relatively easy, as there are really only three different functions: expand, truncate, and translate offset to pointer. So, we will construct an instance of the class, assign it a memory store, and try out the various functions, verifying that after each request that the result is as expected.
Level 2 uses "coverage analysis" to make sure that each line of code in the class is covered by at least one test. In the absence of an abend, and loop, if, and call constructs, a series of statements will be executed from start to finish. So, we know that, in that case, if the first statement is exceuted, then all of them will be executed. Because of this, we can quickly set up a test case to help us make sure that all code is covered by our tests: we put a breakpoint at the beginning of each method and at every "if" (inside the block), "for", "while", etc, and in the "else" block of all ifs. Then we run the test. Each time we hit a breakpoint, we remove the breakpoint since we know that code block is being executed as a result of our tests. When the test finishes, any remaining breakpoints indicate code that never executed. We can then design additional test scenarios that exercise those missed code blocks. In some cases, it may not be possible, because it requires failure modes that are not easy to replicate. Except for these exceptional situations, we ought to be able to verify complete code coverage in our test.
Note that it would be ideal to test every path through our code. For example, given the following code:

if( A ) then
begin
  // case 1
end else
begin
  // case 2
end ;
if( B ) then
begin
  // case 3
end else
begin
  // case 4
end ;

There are 4 paths through this code:

A	B	case
False	False	2, 4
False	True	2, 3
True	False	1, 4
True	True	1, 3

In fact, the number of unique paths through our program will be 2 raised to the number of branches (if statements). So, a class with 30 if statements would have over 1 billion unique paths. Not to mention that all loops count as branches as well. Thus, testing all possible paths is just not feasible. So, simple coverage analysis is the best we can usually manage.
Level 3 is called a "stress test". The idea here is to randomly exercise the class. In the case of our class, we will randomly truncate, extend, translate offsets, and read and write (based on those offsets). We will verify correct operation by reading what was previously written. If we run several hundred million random operations, we can hope to possibly find errors that we missed. There is no guarantee that we will find errors that we missed, and this is not a substitute for good coding. But since everyone makes mistakes, it is nice to have an extra check. In fact, this process did discover a bug that happened under a specific set of circumstances that I hadn't thought of checking in the existing tests. It was in the Truncation code.
Original code (at the end of the truncation loop):

                // Move to next allocation cluster in chain...
                P := Last ;
                if( P <> 0 ) then
                begin
                    inc( Turns ) ;
                    Read( P ) ;
                end ;
            end ; // while( P <> 0 )

Corrected code:

                // Move to next allocation cluster in chain...
                if( ( Value <= 0 ) and ( Last = 0 ) ) then // Done with the truncation
                begin
                    Last := P ;
                    break ;
                end ;
                P := Last ;
                if( P <> 0 ) then
                begin
                    inc( Turns ) ;
                    Read( P ) ;
                end ;
            end ; // while( P <> 0 )

Another benefit of the stress test is that we can get a good estimate as to the performance of the class. In our case, we achieved over 10,000 operations per second on a memory store, on a 3.2 GHz CPU. This includes the random 512-byte reads and writes. We can say, with a fair amount of certainty, that a RAM Disk would support 10,000 file operations per second using our class. That is adequate performance, in my book.
Another benefit of writing a test routine is that we can run it every time we make a change to the code to verify that we didn't break anything. But, we need to remember to add breakpoints to new code to make sure that all new code blocks are covered by our tests. This type of retesting is called "regression testing". That is, we test to make sure the code hasn't regressed to a broken state.
I also added some test "instrumentation" to the class itself to perform various checks, including making sure that all data was freed up when the size was set to 0. All of this test code slowed the speed to about 1,500 operations per second, but I feel much better than about the reliability of the code. I won't bother showing all the instrumentation code, but here is the general test code that I used:

procedure Test ;

var ACM : TCOM_Allocation_Cluster_Manager64 ;
    Buff : array[ 0..511 ] of byte ;
    H : TCOM_Heap ;
    Old_P, P, P1 : int64 ;
    S64 : TCOM_Managed_Store64 ;


    procedure error( s : string ) ;

    begin
        halt ;
    end ;


    procedure Do_Size( P : int64 ) ;

    begin
        ACM.Set_Size( P ) ;
    end ;


    procedure Do_Read( P : int64 ) ;

    var Index : longint ;
        P1 : int64 ;

    begin
        P1 := ACM.Offset_To_Pointer( P * 512 ) ;
        if( P1 <> 0 ) then
        begin
            S64.Read( P1, 512, Buff ) ;
            for Index := 0 to 511 do
            begin
                if( Buff[ Index ] <> P ) then
                begin
                    error( 'Failure' ) ;
                end ;
            end ;
        end ;
    end ;


var CA, Dummy : integer ;
    S : string ;

begin
    // Coverage test...
    ACM := TCOM_Allocation_Cluster_Manager64.Create ;
    S64 := TCOM_Heap64.Create ;
    if( ACM.Get_Store <> nil ) then
    begin
        error( 'Invalid store' ) ;
    end ;
    ACM.Set_Store( S64 ) ;
    if( ACM.Get_Store <> S64 ) then
    begin
        error( 'Invalid store' ) ;
    end ;
    H := TCOM_Heap.Create ;
    ACM.Set_Heap( H ) ;
    if( ACM.Get_Clustersize <> 128 ) then
    begin
        error( 'Invalid clustersize' ) ;
    end ;
    if( ACM.Get_Heap <> H ) then
    begin
        error( 'Invalid heap' ) ;
    end ;
    if( ACM.Get_Size <> 0 ) then
    begin
        error( 'Invalid size' ) ;
    end ;
    if( ACM.Get_Root <> 0 ) then
    begin
        error( 'Invalid root' ) ;
    end ;
    ACM.Set_Clustersize( 512 ) ;
    if( ACM.Get_Clustersize <> 512 ) then
    begin
        error( 'Invalid clustersize' ) ;
    end ;
    if( ACM.Get_Size <> 0 ) then
    begin
        error( 'Invalid size' ) ;
    end ;
    ACM.Set_Size( 65536 ) ;
    if( ACM.Get_Size <> 65536 ) then
    begin
        error( 'Invalid size' ) ;
    end ;
    ACM.Set_Size( 65536 ) ;
    if( ACM.Get_Size <> 65536 ) then
    begin
        error( 'Invalid size' ) ;
    end ;
    ACM.Set_Size( 256 ) ;
    if( ACM.Get_Size <> 512 ) then
    begin
        error( 'Invalid size' ) ;
    end ;
    if( ACM.Offset_To_Pointer( 1024000 ) <> 0 ) then
    begin
        error( 'Invalid translation' ) ;
    end ;
    ACM.Set_Size( 65536 ) ;
    P := ACM.Offset_To_Pointer( 32768 ) ;
    if( P = 0 ) then
    begin
        error( 'Invalid translation' ) ;
    end ;
    fillchar( Buff, 512, 1 ) ;
    S64.Write( P, 512, Buff ) ;
    P := ACM.Offset_To_Pointer( 65500 ) ;
    if( P = 0 ) then
    begin
        error( 'Invalid translation' ) ;
    end ;
    fillchar( Buff, 512, 2 ) ;
    S64.Write( P, 512, Buff ) ;
    P := ACM.Offset_To_Pointer( 32768 ) ;
    S64.Read( P, 512, Buff ) ;
    if( Buff[ 0 ] <> 1 ) then
    begin
        error( 'Invalid data' ) ;
    end ;
    P := ACM.Offset_To_Pointer( 32769 ) ;
    if( P = 0 ) then
    begin
        error( 'Offset_To_Pointer error' ) ;
    end ;
    P := ACM.Offset_To_Pointer( 65500 ) ;
    S64.Read( P, 512, Buff ) ;
    if( Buff[ 0 ] <> 2 ) then
    begin
        error( 'Invalid data' ) ;
    end ;
    if( ACM.Get_Root = 0 ) then
    begin
        error( 'Invalid root' ) ;
    end ;
    ACM.Set_Size( 2*65536 ) ;
    ACM.Set_Size( 0 ) ;

    ACM.Set_Heap( nil ) ;
    ACM.Set_Store( nil ) ;
    ACM.Free ;
    ACM := TCOM_Allocation_Cluster_Manager64.Create ;
    ACM.Free ;

    // Stress test...
{$IFDEF CC_Debug}
    Allocated_CAs.Clear ;
    Other_Allocated.Clear ;
{$ENDIF}
    randomize ;
    ACM := TCOM_Allocation_Cluster_Manager64.Create ;
    S64 := TCOM_Heap64.Create ;
    ACM.Set_Store( S64 ) ;
    H := TCOM_Heap.Create ;
    ACM.Set_Heap( H ) ;
    ACM.Set_Clustersize( 512 ) ;

    try
        while( true ) do
        begin
            case random( 101 ) of
                0..50 : // Set size
                    begin
                        Old_P := ACM.Get_Size ;
                        P := random( 256 ) * 512 ;
                        Do_Size( P ) ;
                        if( P > Old_P ) then // Expand
                        begin
                            Do_Size( P ) ;
                            while( Old_P < P ) do
                            begin
                                P1 := ACM.Offset_To_Pointer( Old_P ) ;
				if( P1 = 0 ) then
				begin
                             	    error( 'Failure' ) ;
				end ;
                                S64.Fill( P1, 512, Old_P div 512 ) ;
                                Old_P := Old_P + 512 ;
                            end ; // while( Old_P < P )
                        end ; // if( P > Old_P )
                    end ;
                51..99 : // Read
                    begin
                        P := random( 256 ) ;
                        Do_Read( P ) ;
                    end ;
                100 : // Zero
                    begin
                        Do_Size( 0 ) ;
                    end ;
            end ;
        end ; // while( true )
    except
    end ;
    ACM.Free ;
end ;

Other applications
There are some other ways we can use our Allocation_Cluster_Manager class, besides using it for managing files on stores. For instance, we can implement a virtual list class that works like the VCL/LCL TList class, but keeps the data in a store (such as a file). There are obviously easier methods of store a list of values in a file. But, what if we want to keep several lists in a file, each of which is updated/resized during the course of program execution? Hence, the TStandard_COM_Store64_List class. I won't bother to discuss the code - I merely present it as an example of the use of our Allocation_Cluster_Manager class which you can examine or skip, as you desire. The point of this exercise is to show that no matter what classes we write for UOS, there are potential other uses for them. Yes, we want things to work optimally for UOS. But we also want to write them so that they can be repurposed for other applications.

type TStandard_COM_Store64_List = class( TCOM_Store64_List )
                              public // Constructors and destructors...
                                  constructor Create ;
                                  destructor Destroy ; override ;

                              private // Instance data...
                                  _ACM : TCOM_Allocation_Cluster_Manager64 ;
                                  _Address : TStore_Address64 ; // Address of header
                                  _Store : TCOM_Managed_Store64 ;
                                  Header : TList_Record ;
                                  _Buffer : PChar ;
                                  _Current_Buffer : TStore_Address64 ; // Current location of Buffer

                              protected { Internal utility routines... }
                                  function Index_To_Offset( Index : longint ) : longint ;
                                  procedure Read( P : TStore_Address64 ) ;
                                  procedure Write( P : TStore_Address64 ) ;

                              public { API... }
                                  function Get_Address : TStore_Address64 ;
                                      override ; stdcall ;
                                  procedure Set_Address( Value : TStore_Address64 ) ;
                                      override ; stdcall ;
                                  function Add( Value : longint ) : longint ;
                                      override ; stdcall ;
                                  function Get_Count : longint ;
                                      override ; stdcall ;
                                  procedure Set_Count( Value : longint ) ;
                                      override ; stdcall ;
                                  function Get_Item( Index : longint ) : longint ;
                                      override ; stdcall ;
                                  procedure Set_Item( Index, Value : longint ) ;
                                      override ; stdcall ;
                                  function Get_Capacity : longint ;
                                      override ; stdcall ;
                                  procedure Set_Capacity( Value : longint ) ;
                                      override ; stdcall ;
                                  function Get_Delta : longint ;
                                      override ; stdcall ;
                                  procedure Set_Delta( Value : longint ) ;
                                      override ; stdcall ;

                                  function Get_Store : TCOM_Managed_Store64 ;
                                      override ; stdcall ;
                                  procedure Set_Store( Value : TCOM_Managed_Store64 ) ;
                                      override ; stdcall ;

                              public // API...
                                  function Is_Class( Name : PChar ) : boolean ;
                                      override ; stdcall ;
                                  function Add_Insert( Value : longint ) : longint ;
                                      override ; stdcall ;
                                  function IndexOf( Value : longint ) : longint ;
                                      override ; stdcall ;
                                  procedure Update_Header ;
                                      override ; stdcall ;
                          end ; // TStandard_COM_Store64_List

// TStandard_COM_Store64_List methods...

// Constructors and destructors...

constructor TStandard_COM_Store64_List.Create ;

begin
    inherited Create ;

    _ACM := TCOM_Allocation_Cluster_Manager64.Create ;
    _ACM.Set_Heap( TCOM_Heap.Create ) ;
end ;


destructor TStandard_COM_Store64_List.Destroy ;

begin
    _ACM.Detach ;
    Set_Store( nil ) ;

    inherited Destroy ;
end ;


{ Internal utility routines... }

procedure TStandard_COM_Store64_List.Read( P : TStore_Address64 ) ;

begin
    if( _Current_Buffer = P ) then // Already have this chunk in the buffer
    begin
        exit ;
    end ;
    _Store.Read( P, Header.Delta * sizeof( longint ), _Buffer^ ) ;
    _Current_Buffer := P ;
end ;


procedure TStandard_COM_Store64_List.Write( P : TStore_Address64 ) ;

begin
    if( P = -1 ) then // Use last address
    begin
        P := _Current_Buffer ;
    end ;
    _Store.Write( P, Header.Delta * sizeof( longint ), _Buffer^ ) ;
    _Current_Buffer := P ;
end ;


{ API... }

function TStandard_COM_Store64_List.Get_Address : TStore_Address64 ;

begin
    Result := _Address ;
end ;


procedure TStandard_COM_Store64_List.Set_Address( Value : TStore_Address64 ) ;

begin
    if( _Address <> Value ) then
    begin
        _Address := Value ;
        if( ( Value <> 0 ) and ( _Store <> nil ) ) then
        begin
            _Store.Read( _Address, sizeof( Header ), Header ) ;
        end else
        begin
            fillchar( Header, sizeof( Header ), 0 ) ;
        end ;
        _ACM.Set_Clustersize( Header.Delta * sizeof( longint ) ) ;
        _ACM.Set_Root( Header.List ) ;
    end ;
end ;


function TStandard_COM_Store64_List.Add( Value : longint ) : longint ;

var P : TStore_Address64 ;
    S : TStore_Address64 ;

begin
    // Make sure enough data is allocated...
    S := Header.Count + 1 ;
    S := S * sizeof( Value ) ; // Offset in data...
    if( Header.Count >= Header.Capacity ) then // Need a larger amount of data
    begin
        Set_Capacity( Header.Capacity + Header.Delta ) ;
        _ACM.Set_Size( S ) ;
        if( Header.Count >= Header.Capacity ) then // Couldn't expand
        begin
            Result := -1 ;
            exit ;
        end ;
    end ;

    // Update header...
    Result := Header.Count ; // This will be the offset we added it at
    inc( Header.Count ) ;
    Update_Header ;

    // Write value...
    P := _ACM.Offset_To_Pointer( S - sizeof( Value ) ) ;
    if( P = 0 ) then
    begin
        Result := -1 ;
        exit ;
    end ;
    Read( P ) ;
    S := Result - ( ( Result div Header.Delta ) * Header.Delta ) ; // Offset in this buffer
    move( Value, _Buffer[ S * sizeof( Value ) ], sizeof( Value ) ) ;
    Write( P ) ;
end ; // TStandard_COM_Store64_List.Add


function TStandard_COM_Store64_List.Get_Count : longint ;

begin
    Result := Header.Count ;
end ;


procedure TStandard_COM_Store64_List.Set_Count( Value : longint ) ;

begin
    Set_Last_Error( nil ) ;
    if( Value < 0 ) then
    begin
        exit ;
    end ;
    if( Value > Capacity ) then
    begin
        Set_Capacity( Value ) ;
    end ;
    if( Value > Capacity ) then // Couldn't expand
    begin
        exit ;
    end ;
    while( Header.Count < Value ) do
    begin
        Add( 0 ) ;
        if( Last_Error <> nil ) then
        begin
            exit ;
        end ;
    end ;
    Header.Count := Value ;
    Update_Header ;
end ;


function TStandard_COM_Store64_List.Index_To_Offset( Index : longint ) : longint ;

var P : TStore_Address64 ;
    S : int64 ;

begin
    S := Index ;
    S := S * sizeof( Result ) ; // Offset in data...
    P := _ACM.Offset_To_Pointer( S ) ;
    Read( P ) ;
    Result := Index - ( ( Index div Header.Delta ) * Header.Delta ) ; // Longint offset in this buffer
    Result := Result * sizeof( longint ) ; // Byte offset in the buffer
end ;


function TStandard_COM_Store64_List.Get_Item( Index : longint ) : longint ;

var S : TStore_Address64 ;

begin
    if( ( Index < 0 ) or ( Index >= Header.Count ) ) then
    begin
        Set_Last_Error( Create_Store_List64_Exception( Store_List64_Err_Invalid_List_Index ) ) ;
        Result := -1 ;
        exit ;
    end ;

    S := Index_To_Offset( Index ) ;
    move( _Buffer[ S ], Result, sizeof( Result ) ) ;
end ;


procedure TStandard_COM_Store64_List.Set_Item( Index, Value : longint ) ;

var S : TStore_Address64 ;

begin
    if( ( Index < 0 ) or ( Index >= Header.Count ) ) then
    begin
        Set_Last_Error( Create_Store_List64_Exception( Store_List64_Err_Invalid_List_Index ) ) ;
        exit ;
    end ;

    S := Index_To_Offset( Index ) ;
    move( Value, _Buffer[ S ], sizeof( Value ) ) ;
    Write( -1 ) ;
end ;


function TStandard_COM_Store64_List.Get_Capacity : longint ;

begin
    Result := Header.Capacity ;
end ;


procedure TStandard_COM_Store64_List.Set_Capacity( Value : longint ) ;

begin
    if( Value < 0 ) then
    begin
        exit ; // Invalid value
    end ;
    if( _Store = nil ) then
    begin
        exit ;
    end ;
    if( Header.Delta = 0 ) then
    begin
        _ACM.Set_Clustersize( 16 ) ;
        Header.Delta := _ACM.Get_Clustersize div sizeof( longint ) ; // Default
    end ;
    if( Value mod Header.Delta <> 0 ) then
    begin
        Value := Value + Header.Delta ;
    end ;
    Value := ( Value div Header.Delta ) * Header.Delta ; // New size
    _ACM.Set_Size( Value * sizeof( longint ) ) ;
    Header.Capacity := _ACM.Get_Size div sizeof( longint ) ;
    Update_Header ;
end ;


function TStandard_COM_Store64_List.Get_Delta : longint ;

begin
    Result := Header.Delta ;
end ;


procedure TStandard_COM_Store64_List.Set_Delta( Value : longint ) ;

begin
    if( Header.List <> 0 ) then // Already have things allocated
    begin
        exit ; // Cannot change delta
    end ;
    if( Value <> Header.Delta ) then
    begin
        _ACM.Set_Clustersize( Value * sizeof( longint ) ) ;
        Header.Delta := _ACM.Get_Clustersize div sizeof( longint ) ;
        Update_Header ;
        Reallocmem( _Buffer, _ACM.Get_Clustersize ) ;
    end ;
end ;


function TStandard_COM_Store64_List.Get_Store : TCOM_Managed_Store64 ;

begin
    Result := _Store ;
end ;


procedure TStandard_COM_Store64_List.Set_Store( Value : TCOM_Managed_Store64 ) ;

begin
    if( Value <> nil ) then
    begin
        Value.Attach ;
    end ;
    if( _Store <> nil ) then
    begin
        _Store.Detach ;
    end ;
    _Store := Value ;
    _Address := 0 ;
    _Current_Buffer := 0 ;
    if( _Store <> nil ) then
    begin
        _ACM.Set_Store( _Store ) ;
        Header.Delta := _Store.Min_Storage div sizeof( longint ) ;
        _ACM.Set_Clustersize( Header.Delta * sizeof( longint ) ) ;
        Reallocmem( _Buffer, _ACM.Get_Clustersize ) ;
    end ;
end ;


function TStandard_COM_Store64_List.Is_Class( Name : PChar ) : boolean ; stdcall ;

var S : string ;

begin
    S := Name ;
    Result := lowercase( S ) = 'tstandard_com_store64_list' ;
end ;


function TStandard_COM_Store64_List.Add_Insert( Value : longint ) : longint ;

begin
    Result := IndexOf( 0 ) ;
    if( Result = -1 ) then
    begin
        Result := Add( Value ) ;
    end else
    begin
        Set_Item( Result, Value ) ;
    end ;
end ;


function TStandard_COM_Store64_List.IndexOf( Value : longint ) : longint ;

var Index : integer ;

begin
    for Index := 0 to Count - 1 do
    begin
        if( Get_Item( Index ) = Value ) then
        begin
            Result := Index ;
            exit ;
        end ;
    end ;
    Result := -1 ;
end ;


procedure TStandard_COM_Store64_List.Update_Header ;

begin
    if( _Store = nil ) then
    begin
        exit ;
    end ;
    if( _Address = 0 ) then
    begin
        _Address := _Store.Allocate( sizeof( Header ) ) ;
    end ;
    if( _Address <> 0 ) then
    begin
        if( Header.List = 0 ) then
        begin
            Header.List := _ACM.Get_Root ;
        end ;
        _Store.Write( _Address, sizeof( Header ), Header ) ;
        if( Header.List <> 0 ) then
        begin
            _ACM.Set_Root( Header.List ) ;
        end ;
    end ;
end ;

In our next article, we will continue building our UOS native file system. Next stop: the native file object.