Call a virtual constructor by id on old style Delphi classes

Question

Before I read object contents from a stream, I read an ID to determine the object type. For this I have to store streaming records (TStreamRec) to link class types to IDs. When I load an ID I have to search for the right streaming record to call the right constructor on then right type.

Unfortunately I have to use old style Delphi class types (TMyClass = object).

My existing solution with objects causes memory management anomalies when I use FastMM4 in Delphi 7. It uses typeOf(X) to get the VMT address of the class and use asm code to call the constructor.

 Asm
    mov eax,vi                  // versionID parameter
    push eax
    mov ecx,self                // the stream prameter
    mov ebx,p                   // the TStreamRec pointer
    mov    edx,[ebx].TStreamRec.classType
    xor eax, eax
    call [ebx].TStreamRec.Load // The stored pointer to the load constructor
    mov result, eax
 End;

It logs an error when the same memory block gets reallocated. (An object created by the new operator, released by its destructor and a little bit later this asm constructor call gives back the same pointer).

Here is below a working code with classes. For an example I created a base class and two descendant classes with a constructor called load. Declared the TStreamRec and a TMyClassRepository to do the object streaming.

You should start the code investigation from TForm2.button1Click (at the very end of the attached source code). The trigger event to test my solution with "new" (not ancient old) style class types.

Is there any way to do the same by old style Delphi class types without FastMM4 error messages?

The pas file of the working example with classes:

unit Unit2;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm2 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

uses
  Generics.Collections
  ;

{$R *.dfm}

type
  CMyBaseClass = class of TMyBaseClass;
  TMyBaseClass = class
    constructor load( stream_ : TStream; versionID_ : integer ); virtual;
  end;

  TMyClass1 = class ( TMyBaseClass )
    constructor load( stream_ : TStream; versionID_ : integer ); override;
  end;

  TMyClass2 = class ( TMyBaseClass )
    constructor load( stream_ : TStream; versionID_ : integer ); override;
  end;

  PStreamRec = ^TStreamRec;
  TStreamRec = packed record
    id : cardinal;
    classType : CMyBaseClass;
  end;

  TStreamRecList = TList<PStreamRec>;

  TMyClassRepository = class
    private
      fStreamRecs : TStreamRecList;

    protected
      function createStreamRecList : TStreamRecList; virtual;
      procedure releaseStreamRecsList; virtual;
      procedure createStreamRecs; virtual;
      procedure releaseStreamRecs; virtual;
      function getClassTypeById( id_ : cardinal ) : CMyBaseClass;

    public
      constructor create;
      destructor destroy; override;
      function loadObject( strm_ : TStream; versionID_ : integer ) : TMyBaseClass;

  end;

constructor TMyBaseClass.load( stream_ : TStream; versionID_ : integer );
begin
  inherited create;
  // Load TMyBaseClass attributes
end;

constructor TMyClass1.load( stream_ : TStream; versionID_ : integer );
begin
  inherited load( stream_, versionID_ );
  // Load TMyClass1 attributes
end;

constructor TMyClass2.load( stream_ : TStream; versionID_ : integer );
begin
  inherited load( stream_, versionID_ );
  // Load TMyClass2 attributes
end;

function TMyClassRepository.createStreamRecList : TStreamRecList;
begin
  result := TStreamRecList.Create;
end;

procedure TMyClassRepository.releaseStreamRecsList;
begin
  if ( fStreamRecs <> NIL ) then
  begin
    releaseStreamRecs;
    fStreamRecs.Free;
    fStreamRecs := NIL;
  end;
end;

procedure TMyClassRepository.createStreamRecs;

    function createStreamRec( id_ : cardinal; classType_ : CMyBaseClass ) : PStreamRec;
    begin
      getMem( result, sizeOf( TStreamRec ) );
      result^.id := id_;
      result^.classType := classType_;
    end;

begin
  fStreamRecs.Add( createStreamRec( 1, TMyClass1 ) );
  fStreamRecs.Add( createStreamRec( 2, TMyClass2 ) );
end;

procedure TMyClassRepository.releaseStreamRecs;
var
  pSR : PStreamRec;
begin
  for pSR in fStreamRecs do
    freeMem( pSR );
end;

function TMyClassRepository.getClassTypeById( id_ : cardinal ) : CMyBaseClass;
var
  i : integer;
  pSR : PStreamRec;
begin
  result := NIL;
  i := fStreamRecs.Count;
  while ( ( result = NIL ) and ( i > 0 ) ) do
  begin
    dec( i );
    pSR := fStreamRecs[i];
    if ( pSR^.id = id_ ) then
      result := pSR^.classType;
  end;
end;

constructor TMyClassRepository.create;
begin
  inherited create;
  fStreamRecs := createStreamRecList;
  createStreamRecs;
end;

destructor TMyClassRepository.Destroy;
begin
  releaseStreamRecsList;
  inherited destroy;
end;

function TMyClassRepository.loadObject( strm_ : TStream; versionID_ : integer ) : TMyBaseClass;
var
  id : cardinal;
  cMBC : CMyBaseClass;
  aMBC : TMyBaseClass;
begin
  strm_.Read( id, sizeOf( cardinal ) );
  cMBC := getClassTypeById( id );
  if ( cMBC <> NIL ) then
    result := cMBC.load( strm_, versionID_ )
  else
    result := NIL;
end;

procedure TForm2.Button1Click(Sender: TObject);
var
  mcRepository : TMyClassRepository;
  strm : TStream;
  cMBC : CMyBaseClass;

  function createInitializedStream : TStream;

    procedure initStreamByIDs( versionID_ : integer; ids_ : array of cardinal );
    var
      id : cardinal;
    begin
      result.Write( versionID_, sizeOf( integer ) );
      for id in ids_ do
        result.Write( id, sizeOf( cardinal ) );
      result.position := 0;
    end;

  begin
    result := TMemoryStream.create;
    initStreamByIDs( 1, [1,2] );
  end;

  procedure loadObjects;
  var
    versionID : integer;
    aMBC : TMyBaseClass;
  begin
    strm.read( versionID, sizeOf( integer ) );
    while ( strm.Position < strm.Size ) do
    begin
      aMBC := mcRepository.loadObject( strm, versionID );
      if ( aMBC <> NIL ) then
        // In this test I don't need the objects so I just release them right now
        aMBC.free;
    end;
  end;

begin
  mcRepository := TMyClassRepository.create;
  try
    strm := createInitializedStream;
    try
      loadObjects;
    finally
      strm.free;
      strm := NIL;
    end;
  finally
    mcRepository.Free;
    mcRepository := NIL;
  end;
end;

The dfm file:

object Form2: TForm2
  Left = 479
  Top = 112
  Caption = 'Form2'
  ClientHeight = 637
  ClientWidth = 1289
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Visible = True
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 840
    Top = 88
    Width = 75
    Height = 25
    Caption = 'Button1'
    TabOrder = 0
    OnClick = Button1Click
  end
end