Hacking virtual class vars with Freepascal

So here's my experiment with hacking virtual class variables into Freepascal. I must warn you this is not pretty.

Every now and then I am doing something that I think would be benefited by virtual class vars. FPC already has class vars but every subclass accesses the same var. They are not virtual. In a way there are some hard coded virtual class vars such as TObject.ClassName

This shows how current class vars operate:

program test;
TA = class
 class var
   MyVariable: Integer;
end;

TB = class(TA);

var
  A: TA;
  B: TB;
begin
  A.MyVariable := 1234;
  B.MyVariable := 4321;
  WriteLn(A.MyVariable);
end.

The output is 4321.With a virtual class var the output would be 1234. Unfortunately FPC does not have virtual class vars so I have devised a terrible hack.

In short I declare a virtual procedure that will never be used, this is a placeholder. Then create a class constructor which finds the index of that procedure in the VMT which is saved to a regular class var. Then I set the VMT entry to nil as if it's an unset variable. And the first part is done. For every virtual class var you will need a regular class var to hold the index of the placeholder VMT entry.

type
  TA = class
  protected
    class var
      cMyVarIndex: Integer;
  private
    class constructor create;
  strict private
    procedure MyVarHolder; virtual; //cannot be abstract
  end;

implementation

class constructor TA.create;
var
  i: Integer;
  c: PPointer;
begin
  c := PPointer(ClassType);
  for i := 0 to MaxInt-1 do
  begin
    if  c[i] = Pointer(@TA.VarHolder1) then
    begin
      cMyVarIndex:=i;
      c[i] := nil;
      break;
    end;
  end;
end;

Now we need a way to set and unset our variable. We will have to access it using a virtual class function and procedure.In my case I used a string type.

protected
    class function GetName: string; virtual;
    class procedure SetName(AValue: string); virtual;
public
    property Name: String read GetName write SetName;

...

class function TA.GetName: string;
var
  c: PPointer;
  P: PString;
begin
  c := PPointer(ClassType);
  P := PString((c[cMyVarIndex]));
  if p = nil then Result := ''
  else
  result := p^;
end;

class procedure TA.SetName(AValue: string);
var
  c: PPointer;
  P: PString;
begin
  c := PPointer(ClassType);
  P := PString((c[cMyVarIndex]));
  if P <> nil then
    DisposeStr(P);
  c[cMyVarIndex] := NewStr(AValue)
end; 

Class properties cannot use virtual methods so I used a property that can only be accessed by an instance.

Here's the complete source for my example.

program test;

{$mode objfpc}{$H+}

uses

  Classes, sysutils;

type
  TA = class(TObject)
  protected
    class var
      cMyVarIndex: Integer;
  private
    class constructor create;
  strict private
    procedure MyVarHolder; virtual; //cannot be abstract
  public
    class function GetName: string; virtual;
    class procedure SetName(AValue: string); virtual;
    property Name: String read GetName write SetName;
  end;

  TB = class (TA)
    class constructor create;
  end;


class constructor TA.create;
var
  i: Integer;
  c: PPointer;
begin
  c := PPointer(ClassType);
  for i := 0 to MaxInt-1 do
  begin
    if  c[i] = Pointer(@TA.MyVarHolder) then
    begin
      cMyVarIndex:=i;
      c[i] := nil;
      break;
    end;
  end;
end;


class function TA.GetName: string;
var
  c: PPointer;
  P: PString;
begin
  c := PPointer(ClassType);
  P := PString((c[cMyVarIndex]));
  if p = nil then
    Result := ''
  else
    Result := p^;
end;

class procedure TA.SetName(AValue: string);
var
  c: PPointer;
  P: PString;
begin
  c := PPointer(ClassType);
  P := PString((c[cMyVarIndex]));
  if P <> nil then
    DisposeStr(P);
  c[cMyVarIndex] := NewStr(AValue)
end;

procedure TA.MyVarHolder;
begin
  // never called!
end;

class constructor TB.create;
var
  c: PPointer;
begin
  c := Pointer(ClassType);
  c[cMyVarIndex] := nil;
end;

var
  A: TA;
  B: TB;
  C: TA;
begin
  A := TA.Create;
  B := TB.Create;
  C := TA.Create; // of type TA

  A.Name := 'Hello';
  B.Name := 'World';

  WriteLn('A Name = ', A.Name);
  WriteLn('B Name = ', B.Name);
  WriteLn('C Name = ', C.Name);

  FreeAndNil(A);
  FreeAndNil(B);
  FreeAndNil(C);
end.

You may have noticed that I had to create a class constructor for TB. This is because the VMT for TB is already initialized with the address of TA.MyVarHolder.

To get around this I made the following changes.

program test;

{$mode objfpc}{$H+}

uses

  Classes, sysutils;

type
  TVirtualClassVarObject = class
  strict private
    procedure vVarsAreSetHolder; virtual; // placeholder. never called
  protected
    class var
      cVarsAreSetIndex: Integer;
    class procedure SetClassVarIndex(var AIndex: Integer; APlaceHolderAddress: Pointer; AShouldNil: Boolean = True); virtual;
  private
    function InitializeVirtualClassVars: Boolean; virtual;
    class constructor Create;
  public
    constructor Create;
  end;

  TA = class(TVirtualClassVarObject)
  strict private
    procedure vNameHolder; virtual; //cannot be abstract. placeholder
  protected
    class var
      cVarNameIndex: Integer;
    class function  GetName: string; virtual;
    class procedure SetName(AValue: string); virtual;
    function InitializeVirtualClassVars: Boolean; override;
  public
    property Name: String read GetName write SetName;
  end;

  TB = class (TA)
  end;

{ TVirtualClassVarObject }

class procedure TVirtualClassVarObject.SetClassVarIndex(var AIndex: Integer;
  APlaceHolderAddress: Pointer; AShouldNil: Boolean);
var
  i: Integer;
  c: PPointer;
begin
  c := PPointer(ClassType);

  if AIndex <> 0 then
  begin
    // we are in a descendant class and index is known
    if AShouldNil then
      c[AIndex] := nil;
    Exit;
  end;

  // find the index
  for i := 0 to MaxInt-1 do
  begin
    if  c[i] = APlaceHolderAddress then
    begin
      AIndex:=i;
      if AShouldNil then
        c[i] := nil;
      break;
    end;
  end;
end;

function TVirtualClassVarObject.InitializeVirtualClassVars: Boolean;
begin
  Result := False;
  if PPointer(ClassType)[cVarsAreSetIndex] = nil then
    Exit;

  PPointer(ClassType)[cVarsAreSetIndex] := nil;
  Result := True;
end;

class constructor TVirtualClassVarObject.Create;
begin
  SetClassVarIndex(cVarsAreSetIndex, @TA.vVarsAreSetHolder, False);
end;

procedure TVirtualClassVarObject.vVarsAreSetHolder;
begin
  // do nothing;
end;

constructor TVirtualClassVarObject.Create;
begin
  InitializeVirtualClassVars;
end;


function TA.InitializeVirtualClassVars: Boolean;
begin
  Result := inherited InitializeVirtualClassVars;
  if Result then
  begin
    SetClassVarIndex(cVarNameIndex, @TA.vNameHolder);
  end;
end;

class function TA.GetName: string;
var
  c: PPointer;
  P: PString;
begin
  c := Pointer(ClassType);
  P := PString((c[cVarNameIndex]));
  if p = nil then
    Result := ''
  else
    Result := p^;
end;

class procedure TA.SetName(AValue: string);
var
  c: PPointer;
  P: PString;
begin
  c := Pointer(ClassType);
  P := PString((c[cVarNameIndex]));
  if P <> nil then
    DisposeStr(P);
  c[cVarNameIndex] := NewStr(AValue)
end;

procedure TA.vNameHolder;
begin
  // never called!
end;

var
  A: TA;
  B: TB;
  C: TA;
begin
  A := TA.Create;
  B := TB.Create;
  C := TA.Create; // of type TA

  A.Name := 'Hello';
  B.Name := 'World';

  WriteLn('A Name = ', A.Name);
  WriteLn('B Name = ', B.Name);
  WriteLn('C Name = ', C.Name);

  FreeAndNil(A);
  FreeAndNil(B);
  FreeAndNil(C);
end.

The output is:
A Name = Hello
B Name = World
C Name = Hello


I added a base object TVirtualClassVarObject; It has a small framework to ease adding virtual class vars to descendant classes. It takes care of initializing class vars to nil in child classes in InitializeVirtualClassVars. You could also set a default value to something else. Each child class would get that default value.

For each variable you want to add you must declare an index variable, virtual procedure and the getter and setter methods. Then in InitializeVirtualClassVars call SetClassVarIndex with the index variable to set and the address of the virtual procedure.

Limitations. There are a couple of limitations I see. Variable types are limited in size to SizeOf(Pointer). If you need a more complex type stored you will have to store a pointer to the data and access it that way, like I have done with the string property. I haven't taken care of disposing of variables that are allocated. This wouldn't be too hard to add. However if you limit your variable types to basic types or pointers to existing data it shouldn't matter. When the class is destructing the program is about to end and it's memory will be freed anyway.

That's it. Now if you really want to you can add virtual class vars to your objects.