paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-24 09:02:29 +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

36
rtl/i386/rttip.inc
View File

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

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

132
rtl/objpas/objpas.pp
View File

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

16
rtl/template/rttip.inc
View File

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