paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-30 08:54:28 +01: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

36
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,7 +118,14 @@ 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
@ -190,7 +204,14 @@ 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
@ -269,7 +290,14 @@ asm
jz .DoArrayDecRef jz .DoArrayDecRef
decb %al decb %al
jz .DoRecordDecRef jz .DoRecordDecRef
decb %al
decb %al
jz .DoObjectDecRef
decb %al
jz .DoClassDecRef
jmp .ExitDecRef jmp .ExitDecRef
.DoClassDecRef:
.DoObjectDecRef:
.DoRecordDecRef: .DoRecordDecRef:
incl %ebx incl %ebx
movzbl (%ebx),%eax movzbl (%ebx),%eax
@ -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

20
rtl/inc/astrings.pp
View File

@ -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;
@ -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;
@ -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;
@ -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

132
rtl/objpas/objpas.pp
View File

@ -18,6 +18,24 @@ unit objpas;
interface 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 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;
@ -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,8 +96,6 @@ 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);
@ -83,9 +105,10 @@ unit objpas;
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,17 +140,17 @@ 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
@ -135,7 +158,7 @@ unit objpas;
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

16
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,7 +162,11 @@ 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