+ rtti for objects and classes

  + TObject.GetClassName implemented

rtl/i386/rttip.inc

@@ -1,7 +1,7 @@
 {
     $Id$
     This file is part of the Free Pascal run time library.
-    Copyright (c) 1993,97 by xxxx
+    Copyright (c) 1998 by Michael Van Canneyt
     member of the Free Pascal development team
 
     See the file COPYING.FPC, included in this distribution,
@@ -35,7 +35,14 @@ asm
 	jz	.DoArrayInit
 	decb	%al
 	jz	.DoRecordInit
+	decb	%al
+	decb	%al
+        jz      .DoObjectInit
+	decb	%al
+        jz      .DoClassInit
 	jmp	.ExitInitialize
+.DoObjectInit:
+.DoClassInit:
 .DoRecordInit:
 	incl	%ebx
 	movzbl	(%ebx),%eax
@@ -111,12 +118,19 @@ asm
 	jz	.DoArrayFinal
 	decb	%al
 	jz	.DoRecordFinal
+	decb	%al
+	decb	%al
+        jz      .DoObjectFinal
+	decb	%al
+        jz      .DoClassFinal
 	jmp	.ExitFinalize
+.DoClassFinal:
+.DoObjectFinal:
 .DoRecordFinal:
 	incl	%ebx
 	movzbl	(%ebx),%eax
 # Skip also recordsize.
-        addl    $5,%eax 
+        addl    $5,%eax
 	addl	%eax,%ebx
 # %ebx points to element count. Set in %edx
 	movl	(%ebx),%edx
@@ -190,12 +204,19 @@ asm
 	jz	.DoArrayAddRef
 	decb	%al
 	jz	.DoRecordAddRef
+	decb	%al
+	decb	%al
+        jz      .DoObjectAddRef
+	decb	%al
+        jz      .DoClassAddRef
 	jmp	.ExitAddRef
+.DoClassAddRef:
+.DoObjectAddRef:
 .DoRecordAddRef:
 	incl	%ebx
 	movzbl	(%ebx),%eax
 # Skip also recordsize.
-        addl    $5,%eax 
+        addl    $5,%eax
 	addl	%eax,%ebx
 # %ebx points to element count. Set in %edx
 	movl	(%ebx),%edx
@@ -269,12 +290,19 @@ asm
 	jz	.DoArrayDecRef
 	decb	%al
 	jz	.DoRecordDecRef
-	jmp	.ExitDecRef
+	decb	%al
+	decb	%al
+        jz      .DoObjectDecRef
+	decb	%al
+        jz      .DoClassDecRef
+        jmp	.ExitDecRef
+.DoClassDecRef:
+.DoObjectDecRef:
 .DoRecordDecRef:
 	incl	%ebx
 	movzbl	(%ebx),%eax
 # Skip also recordsize.
-        addl    $5,%eax 
+        addl    $5,%eax
 	addl	%eax,%ebx
 # %ebx points to element count. Set in %edx
 	movl	(%ebx),%edx
@@ -333,7 +361,11 @@ end;
 
 {
   $Log$
-  Revision 1.5  1998-06-25 08:41:43  florian
+  Revision 1.6  1998-08-23 20:58:50  florian
+    + rtti for objects and classes
+    + TObject.GetClassName implemented
+
+  Revision 1.5  1998/06/25 08:41:43  florian
     * better rtti
 
   Revision 1.4  1998/06/17 11:50:43  michael

rtl/inc/astrings.pp

@@ -29,10 +29,10 @@
   @    : String + Terminating #0;
   Pchar(Ansistring) is a valid typecast.
   So AS[i] is converted to the address @AS+i-1.
-  
+
   Constants should be assigned a reference count of -1
   Meaning that they can't be disposed of.
-  
+
 }
 
 Type shortstring=string;
@@ -44,7 +44,7 @@ Procedure Incr_Ansi_Ref (Var S : AnsiString); forward;
 Procedure AssignAnsiString (Var S1 : AnsiString; S2 : Pointer); forward;
 Procedure Ansi_String_Concat (Var S1 : AnsiString; Var S2 : AnsiString); forward;
 Procedure Ansi_ShortString_Concat (Var S1: AnsiString; Var S2 : ShortString); forward;
-Procedure Ansi_To_ShortString (Var S1 : ShortString; Var S2 : AnsiString; maxlen : longint); forward;
+Procedure Ansi_To_ShortString (Var S1 : ShortString; S2 : Pointer; maxlen : longint); forward;
 Procedure Short_To_AnsiString (Var S1 : AnsiString; Const S2 : ShortString); forward;
 Function  AnsiCompare (Var S1,S2 : AnsiString): Longint; forward;
 Function  AnsiCompare (var S1 : AnsiString; Var S2 : ShortString): Longint; forward;
@@ -58,7 +58,7 @@ Type TAnsiRec = Record
       First : Char;
      end;
      PAnsiRec = ^TAnsiRec;
-          
+
 Const AnsiRecLen = SizeOf(TAnsiRec);
       FirstOff   = SizeOf(TAnsiRec)-1;
       
@@ -74,9 +74,9 @@ begin
     Writeln ('String is nil')
   Else
     Begin
-    With PansiRec(Pointer(S)-Firstoff)^ do
+    With PAnsiRec(Pointer(S)-Firstoff)^ do
       begin
-      Writeln ('MAxlen : ',maxlen);
+      Writeln ('Maxlen : ',maxlen);
       Writeln ('Len    : ',len);
       Writeln ('Ref    : ',ref);
       end;  
@@ -220,7 +220,7 @@ begin
     begin
     Size:=PAnsiRec(Pointer(S2)-FirstOff)^.Len;
     Location:=Length(S1);
-    { Setlength takes case of uniqueness 
+    { Setlength takes case of uniqueness
       and allocated memory. We need to use length, 
       to take into account possibility of S1=Nil }
 //!!    SetLength (S1,Size+Location); 
@@ -249,17 +249,17 @@ begin
   PByte( Pointer(S1)+length(S1) )^:=0; { Terminating Zero }
 end;
 
-
-Procedure Ansi_To_ShortString (Var S1 : ShortString; Var S2 : AnsiString; Maxlen : Longint);  [Public, alias: 'FPC_TO_ANSISTRING_SHORT'];
+Procedure Ansi_To_ShortString (Var S1 : ShortString;S2 : Pointer; Maxlen : Longint);
+  [Public, alias: 'FPC_TO_ANSISTRING_SHORT'];
 {
  Converts a AnsiString to a ShortString;
 }
 Var Size : Longint;
 
 begin
-  Size:=PAnsiRec(Pointer(S2)-FirstOff)^.Len;
+  Size:=PAnsiRec(S2-FirstOff)^.Len;
   If Size>maxlen then Size:=maxlen;
-  Move (Pointer(S2)^,S1[1],Size);
+  Move (S2^,S1[1],Size);
   byte(S1[0]):=Size;
 end;
 
@@ -388,7 +388,7 @@ begin
     PByte (Pointer(S)+l)^:=0;
     end
   else if l>0 then
-    begin  
+    begin
     If (PAnsiRec(Pointer(S)-FirstOff)^.Maxlen < L) or
        (PAnsiRec(Pointer(S)-FirstOff)^.Ref <> 1) then
       begin
@@ -400,10 +400,10 @@ begin
       Pointer(S):=Temp;
       end;
     PAnsiRec(Pointer(S)-FirstOff)^.Len:=l
-    end 
+    end
   else
     { Length=0 }
-    begin  
+    begin
     Decr_Ansi_Ref (S);
     S:=Nil;
     end;
@@ -417,7 +417,7 @@ begin
   ResultAddress:=Nil;
   dec(index);
   { Check Size. Accounts for Zero-length S }
-  if Length(S)<Index+Size then 
+  if Length(S)<Index+Size then
     Size:=Length(S)-Index; 
   If Size>0 then
     begin
@@ -683,7 +683,11 @@ end;
 
 {
   $Log$
-  Revision 1.12  1998-08-22 09:32:12  michael
+  Revision 1.13  1998-08-23 20:58:51  florian
+    + rtti for objects and classes
+    + TObject.GetClassName implemented
+
+  Revision 1.12  1998/08/22 09:32:12  michael
   + minor fixes typos, and ansi2pchar
 
   Revision 1.11  1998/08/08 12:28:10  florian

rtl/objpas/objpas.pp

@@ -16,9 +16,27 @@
 
 unit objpas;
 
-  interface  
-
-    type       
+  interface
+
+    const
+       // vmtSelfPtr           = -36;  { not implemented yet }
+       vmtIntfTable         = -32;
+       vmtAutoTable         = -28;
+       vmtInitTable         = -24;
+       vmtTypeInfo          = -20;
+       vmtFieldTable        = -16;
+       vmtMethodTable       = -12;
+       vmtDynamicTable      = -8;
+       vmtClassName         = -4;
+       vmtInstanceSize      = 0;
+       vmtParent            = 8;
+       vmtDestroy           = 12;
+       vmtNewInstance       = 16;
+       vmtFreeInstance      = 20;
+       vmtSafeCallException = 24;
+       vmtDefaultHandler    = 28;
+
+    type
        { first, in object pascal, the types must be redefined }
        smallint = system.integer;
        integer = system.longint;
@@ -28,25 +46,32 @@ unit objpas;
 
        { some pointer definitions }
        pshortstring = ^shortstring;
-       // pansistring = ^ansistring;
-       // pwidestring = ^widestring;
+       plongstring = ^longstring;
+       pansistring = ^ansistring;
+       pwidestring = ^widestring;
        // pstring = pansistring;
        pextended = ^extended;
-       
+       ppointer = ^pointer;
 
        { now the let's declare the base classes for the class object }
        { model                                                       }
        tobject = class;
        tclass = class of tobject;
+       pclass = ^tclass;
 
        tobject = class
           { please don't change the order of virtual methods, because      }
           { their vmt offsets are used by some assembler code which uses   }
           { hard coded addresses      (FK)                                 }
           constructor create;
+          { the virtual procedures must be in THAT order }
           destructor destroy;virtual;
           class function newinstance : tobject;virtual;
           procedure freeinstance;virtual;
+          function safecallexception(exceptobject : tobject;
+            exceptaddr : pointer) : integer;virtual;
+          procedure defaulthandler(var message);virtual;
+
           procedure free;
           class function initinstance(instance : pointer) : tobject;
           procedure cleanupinstance;
@@ -60,7 +85,6 @@ unit objpas;
 
           { message handling routines }
           procedure dispatch(var message);
-          procedure defaulthandler(var message);virtual;
 
           class function methodaddress(const name : shortstring) : pointer;
           class function methodname(address : pointer) : shortstring;
@@ -72,20 +96,19 @@ unit objpas;
           class function getinterfaceentry(const iid : tguid) : pinterfaceentry;
           class function getinterfacetable : pinterfacetable;
           }
-          function safecallexception(exceptobject : tobject;
-            exceptaddr : pointer) : integer;virtual;
        end;
-       
+
        TExceptProc = Procedure (Obj : TObject; Addr: Pointer);
-       
+
        var
           abstracterrorproc : pointer;
        Const
           ExceptProc : Pointer {TExceptProc} = Nil;
-          
 
   implementation
 
+    procedure finalize(data,typeinfo : pointer);external name 'FINALIZE';
+
     { the reverse order of the parameters make code generation easier }
     function _is(aclass : tclass;aobject : tobject) : boolean;[public,alias: 'DO_IS'];
 
@@ -98,7 +121,7 @@ unit objpas;
 
       begin
          if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then
-           { throw an exception }
+           runerror(219);
       end;
 
     procedure abstracterror;[public,alias: 'ABSTRACTERROR'];
@@ -117,25 +140,25 @@ unit objpas;
   {                               TOBJECT                                  }
   {************************************************************************}
 
-      constructor tobject.create;
+      constructor TObject.Create;
 
         begin
         end;
 
-      destructor tobject.destroy;
+      destructor TObject.Destroy;
 
         begin
         end;
 
-      procedure tobject.free;
+      procedure TObject.Free;
 
         begin
            // the call via self avoids a warning
            if self<>nil then
-             self.destroy;  
+             self.destroy;
         end;
 
-      class function tobject.instancesize : longint;
+      class function TObject.InstanceSize : LongInt;
 
         type
            plongint = ^longint;
@@ -143,107 +166,101 @@ unit objpas;
         begin
            { type of self is class of tobject => it points to the vmt }
            { the size is saved at offset 0                            }
-           instancesize:=plongint(self)^;
+           InstanceSize:=plongint(self)^;
         end;
 
-      class function tobject.initinstance(instance : pointer) : tobject;
-
-        type
-           ppointer = ^pointer;
+      class function TObject.InitInstance(instance : pointer) : tobject;
 
         begin
            fillchar(instance^,self.instancesize,0);
            { insert VMT pointer into the new created memory area }
            { (in class methods self contains the VMT!)           }
            ppointer(instance)^:=pointer(self);
-           initinstance:=tobject(instance);
+           InitInstance:=TObject(Instance);
         end;
 
-      class function tobject.classparent : tclass;
-
-        type
-           ptclass = ^tclass;
+      class function TObject.ClassParent : tclass;
 
         begin
            { type of self is class of tobject => it points to the vmt }
-           { the parent vmt is saved at offset 8                      }
-           classparent:=(ptclass(self)+8)^;
+           { the parent vmt is saved at offset vmtParent              }
+           classparent:=(pclass(self)+vmtParent)^;
         end;
 
-      class function tobject.newinstance : tobject;
+      class function TObject.NewInstance : tobject;
 
         var
            p : pointer;
 
         begin
            getmem(p,instancesize);
-           initinstance(p);
-           newinstance:=tobject(p);
+           InitInstance(p);
+           NewInstance:=TObject(p);
         end;
 
-      procedure tobject.freeinstance;
+      procedure TObject.FreeInstance;
 
         var
-           p : pointer;
+           p : Pointer;
 
         begin
-           { !!! we should finalize some data }
+           CleanupInstance;
 
            { self is a register, so we can't pass it call by reference }
-           p:=pointer(self);
-           freemem(p,instancesize);
+           p:=Pointer(Self);
+           FreeMem(p,InstanceSize);
         end;
 
-      function tobject.classtype : tclass;
+      function TObject.ClassType : TClass;
 
         begin
-           classtype:=tclass(pointer(self)^)
+           ClassType:=TClass(Pointer(Self)^)
         end;
 
-      class function tobject.methodaddress(const name : shortstring) : pointer;
+      class function TObject.MethodAddress(const name : shortstring) : pointer;
 
         begin
            methodaddress:=nil;
         end;
 
-      class function tobject.methodname(address : pointer) : shortstring;
+      class function TObject.MethodName(address : pointer) : shortstring;
 
         begin
            methodname:='';
         end;
 
-      function tobject.fieldaddress(const name : shortstring) : pointer;
+      function TObject.FieldAddress(const name : shortstring) : pointer;
 
         begin
            fieldaddress:=nil;
         end;
 
-      function tobject.safecallexception(exceptobject : tobject;
+      function TObject.safecallexception(exceptobject : tobject;
         exceptaddr : pointer) : integer;
 
         begin
            safecallexception:=0;
         end;
 
-      class function tobject.classinfo : pointer;
+      class function TObject.ClassInfo : pointer;
 
         begin
-           classinfo:=nil;
+           ClassInfo:=(PPointer(self)+vmtTypeInfo)^;
         end;
 
-      class function tobject.classname : shortstring;
+      class function TObject.ClassName : ShortString;
 
         begin
-           classname:='';
+           ClassName:=PShortString((PPointer(Self)+vmtClassName)^)^;
         end;
 
-      class function tobject.classnameis(const name : string) : boolean;
+      class function TObject.classnameis(const name : string) : boolean;
 
         begin
            classnameis:=classname=name;
         end;
 
-      class function tobject.inheritsfrom(aclass : tclass) : boolean;
+      class function TObject.InheritsFrom(aclass : TClass) : Boolean;
 
         var
            c : tclass;
@@ -254,27 +271,36 @@ unit objpas;
              begin
                 if c=aclass then
                   begin
-                     inheritsfrom:=true;
+                     InheritsFrom:=true;
                      exit;
                   end;
-                c:=c.classparent;
+                c:=c.ClassParent;
              end;
-           inheritsfrom:=false;
+           InheritsFrom:=false;
         end;
 
-      procedure tobject.dispatch(var message);
+      procedure TObject.Dispatch(var message);
 
         begin
         end;
 
-      procedure tobject.defaulthandler(var message);
+      procedure TObject.DefaultHandler(var message);
 
         begin
         end;
 
-      procedure tobject.cleanupinstance;
+      procedure TObject.CleanupInstance;
+
+        var
+           vmt : tclass;
 
         begin
+           vmt:=ClassType;
+           while vmt<>nil do
+             begin
+                Finalize(Pointer(Self),Pointer(vmt)+vmtInitTable);
+                vmt:=vmt.ClassParent;
+             end;
         end;
 
 {$i except.inc}
@@ -284,7 +310,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.5  1998-07-30 16:10:11  michael
+  Revision 1.6  1998-08-23 20:58:52  florian
+    + rtti for objects and classes
+    + TObject.GetClassName implemented
+
+  Revision 1.5  1998/07/30 16:10:11  michael
   + Added support for ExceptProc+
 
   Revision 1.4  1998/07/29 15:44:33  michael

rtl/template/rttip.inc

@@ -1,7 +1,7 @@
 {
     $Id$
     This file is part of the Free Pascal run time library.
-    Copyright (c) 1993,97 by xxxx
+    Copyright (c) 1998 by Michael Van Canneyt
     member of the Free Pascal development team
 
     See the file COPYING.FPC, included in this distribution,
@@ -38,7 +38,7 @@ begin
       For I:=0 to Count-1 do
         Initialize (Data+(I*size),TInfo);   
       end; 
-    tkrecord :
+    tkRecord,tkObject,tkClass:
       begin
       Temp:=Temp+1;
       I:=Temp^;
@@ -74,7 +74,7 @@ begin
       For I:=0 to Count-1 do
         Finalize (Data+(I*size),TInfo);   
       end; 
-    tkrecord :
+    tkRecord,tkObject,tkClass:
       begin
       Temp:=Temp+1;
       I:=Temp^;
@@ -110,7 +110,7 @@ begin
       For I:=0 to Count-1 do
         AddRef (Data+(I*size),TInfo);   
       end; 
-    tkrecord :
+    tkRecord,tkObject,tkClass:
       begin
       Temp:=Temp+1;
       I:=Temp^;
@@ -146,7 +146,7 @@ begin
       For I:=0 to Count-1 do
         DecRef (Data+(I*size),TInfo);   
       end; 
-    tkrecord :
+    tkRecord,tkObject,tkClass:
       begin
       Temp:=Temp+1;
       I:=Temp^;
@@ -162,10 +162,14 @@ end;
 
 {
   $Log$
-  Revision 1.2  1998-06-08 19:32:16  michael
+  Revision 1.3  1998-08-23 20:58:53  florian
+    + rtti for objects and classes
+    + TObject.GetClassName implemented
+
+  Revision 1.2  1998/06/08 19:32:16  michael
   + Implemented DecRef
 
   Revision 1.1  1998/06/08 15:32:14  michael
   + Split rtti according to processor. Implemented optimized i386 code.
 
-}
+}