Smart pascal source code


type
  TBase = class
    class function GetName: string; virtual;
    class procedure SetName(v: string); virtual;
    property Name: string read GetName write SetName;
  end;

type
  TChild = class(TBase)
    class function GetName: string; override;
    class procedure SetName(v: string); override;
  end;

type
  TSubChild = class(TChild)
    class procedure SetName(v: string); override;
  end;

class function TBase.GetName: string;
begin
  Result := 'Base';
end;

class procedure TBase.SetName(v: string);
begin
  WriteLn('TBase.SetName on ' + Name + ' with ' + v);
end;

class function TChild.GetName: string;
begin
  Result := 'Child';
end;

class procedure TChild.SetName(v: string);
begin
  WriteLn('TChild.SetName on ' + Name + ' with ' + v);
end;

class procedure TSubChild.SetName(v: string);
begin
  WriteLn('TSubChild.SetName on ' + Name + ' with ' + v);
end;

{ main.pas }

var
  v: class of TBase;
  o: TBase;

Begin
WriteLn('Direct');
  TBase.Name := TBase.Name;
  TChild.Name := TChild.Name;
  TSubChild.Name := TSubChild.Name;

WriteLn('Class Var');
  v := TBase;
  v.Name := v.Name;
  v := TChild;
  v.Name := v.Name;
  v := TSubChild;
  v.Name := v.Name;

WriteLn('Object Var');
  o := TBase.Create;
  o.Name := o.Name;
  o := TChild.Create;
  o.Name := o.Name;
  o := TSubChild.Create;
  o.Name := o.Name;

  o := nil;
try
  o.Name := o.Name;
except
  on E: Exception do
    WriteLn(e.Message);
end;

{ ### CONSOLE OUTPUTS ###
 Direct
  TBase.SetName on Base with Base
  TChild.SetName on Child with Child
  TSubChild.SetName on Child with Child
 Class Var
  TBase.SetName on Base with Base
  TChild.SetName on Child with Child
  TSubChild.SetName on Child with Child
 Object Var
  TBase.SetName on Base with Base
  TChild.SetName on Child with Child
  TSubChild.SetName on Child with Child
  TypeError, Cannot read property 'ClassType' of null
}

      var v = null;
      var o = null;
      WriteLn("Direct");
      TBase.SetName$(TBase,TBase.GetName$(TBase));
      TBase.SetName$(TChild,TBase.GetName$(TChild));
      TBase.SetName$(TSubChild,TBase.GetName$(TSubChild));
      WriteLn("Class Var");
      v = TBase;
      TBase.SetName$(v,TBase.GetName$(v));
      v = TChild;
      TBase.SetName$(v,TBase.GetName$(v));
      v = TSubChild;
      TBase.SetName$(v,TBase.GetName$(v));
      WriteLn("Object Var");
      o = TObject.Create($New(TBase));
      TBase.SetName$(o.ClassType,TBase.GetName$(o.ClassType));
      o = TObject.Create($New(TChild));
      TBase.SetName$(o.ClassType,TBase.GetName$(o.ClassType));
      o = TObject.Create($New(TSubChild));
      TBase.SetName$(o.ClassType,TBase.GetName$(o.ClassType));
      o = null;
      try {
         TBase.SetName$(o.ClassType,TBase.GetName$(o.ClassType));
      } catch ($e) {
         var E = $W($e);
         WriteLn(E.FMessage)      }
   }
/// TBase = class (TObject)
///  [line: 72, column: 3, file: uMain]
var TBase = {
   $ClassName:"TBase",$Parent:TObject
   ,$Init:function ($) {
      TObject.$Init($);
   }
   /// function TBase.GetName() : String
   ///  [line: 89, column: 22, file: uMain]
   ,GetName:function(Self) {
      return "Base";
   }
   /// procedure TBase.SetName(v: String)
   ///  [line: 94, column: 23, file: uMain]
   ,SetName:function(Self, v$1) {
      WriteLn(("TBase.SetName on "+TBase.GetName$(Self)+" with "+v$1));
   }
   ,Destroy:TObject.Destroy
   ,GetName$:function($){return $.GetName($)}
   ,SetName$:function($){return $.SetName.apply($.ClassType, arguments)}
};
/// TChild = class (TBase)
///  [line: 79, column: 3, file: uMain]
var TChild = {
   $ClassName:"TChild",$Parent:TBase
   ,$Init:function ($) {
      TBase.$Init($);
   }
   /// function TChild.GetName() : String
   ///  [line: 99, column: 23, file: uMain]
   ,GetName:function(Self) {
      return "Child";
   }
   /// procedure TChild.SetName(v: String)
   ///  [line: 104, column: 24, file: uMain]
   ,SetName:function(Self, v$2) {
      WriteLn(("TChild.SetName on "+TBase.GetName$(Self)+" with "+v$2));
   }
   ,Destroy:TObject.Destroy
   ,GetName$:function($){return $.GetName($)}
   ,SetName$:function($){return $.SetName.apply($.ClassType, arguments)}
};
/// TSubChild = class (TChild)
///  [line: 85, column: 3, file: uMain]
var TSubChild = {
   $ClassName:"TSubChild",$Parent:TChild
   ,$Init:function ($) {
      TChild.$Init($);
   }
   /// procedure TSubChild.SetName(v: String)
   ///  [line: 109, column: 27, file: uMain]
   ,SetName:function(Self, v$3) {
      WriteLn(("TSubChild.SetName on "+TBase.GetName$(Self)+" with "+v$3));
   }
   ,Destroy:TObject.Destroy
   ,GetName:TChild.GetName
   ,SetName$:function($){return $.SetName.apply($.ClassType, arguments)}
};