Smart pascal source code


type
  TMyClass = class
    procedure WriteLnMyName; virtual;
    procedure WriteLnClassName;
  end;
type
  TChild = class(TMyClass)
    procedure WriteLnMyName; override;
  end;

procedure TMyClass.WriteLnMyName;
begin
  Writeln('Ancestor: ' + ClassName);
end;

procedure TMyClass.WriteLnClassName;
begin
  Writeln(ClassName);
end;

procedure TChild.WriteLnMyName;
begin
  Writeln('I''m ' + ClassName);
end;

{ main.pas }

var
  o: TObject;
  c: TClass;

Begin
  o := TObject.Create;
  c := TObject;
  Writeln(TObject.ClassName);
  Writeln(o.ClassName);
  Writeln(c.ClassName);

  o := TMyClass.Create;
  c := TMyClass;
  TMyClass(o).WriteLnMyName;
  TMyClass(o).WriteLnClassName;
  Writeln(TMyClass.ClassName);
  Writeln(o.ClassName);
  Writeln(c.ClassName);

  o := TChild.Create;
  c := TChild;
  TMyClass(o).WriteLnMyName;
  TMyClass(o).WriteLnClassName;
  Writeln(TChild.ClassName);
  Writeln(o.ClassName);
  Writeln(c.ClassName);
{ <<< CONSOLE OUTPUTS >>>

  TObject
  TObject
  TObject
  Ancestor: TMyClass
  TMyClass
  TMyClass
  TMyClass
  TMyClass
  I'm TChild
  TChild
  TChild
  TChild
  TChild
}

var Exception={
	$ClassName: "Exception",
	$Parent: TObject,
	$Init: function () { FMessage="" },
	Create: function (s,Msg) { s.FMessage=Msg; return s }
}
function $ToClassType(o) {
	if (o===null) return o;
	return o.ClassType
}
;
function $New(c) { var i={ClassType:c}; c.$Init(i); return i }
function $Is(o,c) {
	if (o===null) return false;
	return $Inh(o.ClassType,c);
}
;
function $Inh(s,c) {
	if (s===null) return false;
	while ((s)&&(s!==c)) s=s.$Parent;
	return (s)?true:false;
}
;
function $As(o,c) {
	if ((o===null)||$Is(o,c)) return o;
	throw Exception.Create($New(Exception),"Cannot cast instance of type \""+o.ClassType.$ClassName+"\" to class \""+c.$ClassName+"\"");
}

      var o = null;
      var c = null;
      o = TObject.Create($New(TObject));
      c = TObject;
      WriteLn(ClassName$1(TObject));
      WriteLn(ClassName$1($ToClassType(o)));
      WriteLn(ClassName$1(c));
      o = TObject.Create($New(TMyClass$1));
      c = TMyClass$1;
      TMyClass$1.WriteLnMyName$($As(o,TMyClass$1));
      TMyClass$1.WriteLnClassName($As(o,TMyClass$1));
      WriteLn(ClassName$1(TMyClass$1));
      WriteLn(ClassName$1($ToClassType(o)));
      WriteLn(ClassName$1(c));
      o = TObject.Create($New(TChild));
      c = TChild;
      TMyClass$1.WriteLnMyName$($As(o,TMyClass$1));
      TMyClass$1.WriteLnClassName($As(o,TMyClass$1));
      WriteLn(ClassName$1(TChild));
      WriteLn(ClassName$1($ToClassType(o)));
      WriteLn(ClassName$1(c));
	  
/// TMyClass = class (TObject)
///  [line: 72, column: 3, file: uMain]
var TMyClass$1 = {
   $ClassName:"TMyClass",$Parent:TObject
   ,$Init:function ($) {
      TObject.$Init($);
   }
   /// procedure TMyClass.WriteLnMyName()
   ///  [line: 81, column: 20, file: uMain]
   ,WriteLnMyName:function(Self) {
      WriteLn(("Ancestor: "+TObject.ClassName(Self.ClassType)));
   }
   /// procedure TMyClass.WriteLnClassName()
   ///  [line: 86, column: 20, file: uMain]
   ,WriteLnClassName:function(Self) {
      WriteLn(TObject.ClassName(Self.ClassType));
   }
   ,Destroy:TObject.Destroy
   ,WriteLnMyName$:function($){return $.ClassType.WriteLnMyName($)}
};
/// TChild = class (TMyClass)
///  [line: 77, column: 3, file: uMain]
var TChild = {
   $ClassName:"TChild",$Parent:TMyClass$1
   ,$Init:function ($) {
      TMyClass$1.$Init($);
   }
   /// procedure TChild.WriteLnMyName()
   ///  [line: 91, column: 18, file: uMain]
   ,WriteLnMyName:function(Self) {
      WriteLn(("I'm "+TObject.ClassName(Self.ClassType)));
   }
   ,Destroy:TObject.Destroy
   ,WriteLnMyName$:function($){return $.ClassType.WriteLnMyName($)}
};