paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-24 13:21:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ rtti for objects and classes

Browse Source 
+ TObject.GetClassName implemented
This commit is contained in:
florian 1998-08-23 20:58:50 +00:00
parent c1c5ec3235
commit cb2b504eb1
4 changed files with 155 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
rtl/i386/rttip.inc
View File

@ -1,7 +1,7 @@
{ {
$Id$ $Id$
This file is part of the Free Pascal run time library. 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 member of the Free Pascal development team
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
@ -35,7 +35,14 @@ asm
jz .DoArrayInit jz .DoArrayInit
decb %al decb %al
jz .DoRecordInit jz .DoRecordInit
decb %al
decb %al
jz .DoObjectInit
decb %al
jz .DoClassInit
jmp .ExitInitialize jmp .ExitInitialize
.DoObjectInit:
.DoClassInit:
.DoRecordInit: .DoRecordInit:
incl %ebx incl %ebx
movzbl (%ebx),%eax movzbl (%ebx),%eax
@ -111,12 +118,19 @@ asm
jz .DoArrayFinal jz .DoArrayFinal
decb %al decb %al
jz .DoRecordFinal jz .DoRecordFinal
decb %al
decb %al
jz .DoObjectFinal
decb %al
jz .DoClassFinal
jmp .ExitFinalize jmp .ExitFinalize
.DoClassFinal:
.DoObjectFinal:
.DoRecordFinal: .DoRecordFinal:
incl %ebx incl %ebx
movzbl (%ebx),%eax movzbl (%ebx),%eax
# Skip also recordsize. # Skip also recordsize.
addl $5,%eax addl $5,%eax
addl %eax,%ebx addl %eax,%ebx
# %ebx points to element count. Set in %edx # %ebx points to element count. Set in %edx
movl (%ebx),%edx movl (%ebx),%edx
@ -190,12 +204,19 @@ asm
jz .DoArrayAddRef jz .DoArrayAddRef
decb %al decb %al
jz .DoRecordAddRef jz .DoRecordAddRef
decb %al
decb %al
jz .DoObjectAddRef
decb %al
jz .DoClassAddRef
jmp .ExitAddRef jmp .ExitAddRef
.DoClassAddRef:
.DoObjectAddRef:
.DoRecordAddRef: .DoRecordAddRef:
incl %ebx incl %ebx
movzbl (%ebx),%eax movzbl (%ebx),%eax
# Skip also recordsize. # Skip also recordsize.
addl $5,%eax addl $5,%eax
addl %eax,%ebx addl %eax,%ebx
# %ebx points to element count. Set in %edx # %ebx points to element count. Set in %edx
movl (%ebx),%edx movl (%ebx),%edx
@ -269,12 +290,19 @@ asm
jz .DoArrayDecRef jz .DoArrayDecRef
decb %al decb %al
jz .DoRecordDecRef jz .DoRecordDecRef
jmp .ExitDecRef decb %al
decb %al
jz .DoObjectDecRef
decb %al
jz .DoClassDecRef
jmp .ExitDecRef
.DoClassDecRef:
.DoObjectDecRef:
.DoRecordDecRef: .DoRecordDecRef:
incl %ebx incl %ebx
movzbl (%ebx),%eax movzbl (%ebx),%eax
# Skip also recordsize. # Skip also recordsize.
addl $5,%eax addl $5,%eax
addl %eax,%ebx addl %eax,%ebx
# %ebx points to element count. Set in %edx # %ebx points to element count. Set in %edx
movl (%ebx),%edx movl (%ebx),%edx
@ -333,7 +361,11 @@ end;
{ {
$Log$ $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 * better rtti
Revision 1.4 1998/06/17 11:50:43 michael Revision 1.4 1998/06/17 11:50:43 michael

36
rtl/inc/astrings.pp
View File

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

142
rtl/objpas/objpas.pp
View File

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

18
rtl/template/rttip.inc
View File

@ -1,7 +1,7 @@
{ {
$Id$ $Id$
This file is part of the Free Pascal run time library. 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 member of the Free Pascal development team
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
@ -38,7 +38,7 @@ begin
For I:=0 to Count-1 do For I:=0 to Count-1 do
Initialize (Data+(I*size),TInfo); Initialize (Data+(I*size),TInfo);
end; end;
tkrecord : tkRecord,tkObject,tkClass:
begin begin
Temp:=Temp+1; Temp:=Temp+1;
I:=Temp^; I:=Temp^;
@ -74,7 +74,7 @@ begin
For I:=0 to Count-1 do For I:=0 to Count-1 do
Finalize (Data+(I*size),TInfo); Finalize (Data+(I*size),TInfo);
end; end;
tkrecord : tkRecord,tkObject,tkClass:
begin begin
Temp:=Temp+1; Temp:=Temp+1;
I:=Temp^; I:=Temp^;
@ -110,7 +110,7 @@ begin
For I:=0 to Count-1 do For I:=0 to Count-1 do
AddRef (Data+(I*size),TInfo); AddRef (Data+(I*size),TInfo);
end; end;
tkrecord : tkRecord,tkObject,tkClass:
begin begin
Temp:=Temp+1; Temp:=Temp+1;
I:=Temp^; I:=Temp^;
@ -146,7 +146,7 @@ begin
For I:=0 to Count-1 do For I:=0 to Count-1 do
DecRef (Data+(I*size),TInfo); DecRef (Data+(I*size),TInfo);
end; end;
tkrecord : tkRecord,tkObject,tkClass:
begin begin
Temp:=Temp+1; Temp:=Temp+1;
I:=Temp^; I:=Temp^;
@ -162,10 +162,14 @@ end;
{ {
$Log$ $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 + Implemented DecRef
Revision 1.1 1998/06/08 15:32:14 michael Revision 1.1 1998/06/08 15:32:14 michael
+ Split rtti according to processor. Implemented optimized i386 code. + Split rtti according to processor. Implemented optimized i386 code.
} }