mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 18:11:55 +01:00
+ rtti for objects and classes
+ TObject.GetClassName implemented
This commit is contained in:
florian
parent
c1c5ec3235
commit
cb2b504eb1
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user