paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 19:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

More changes for type-information

Browse Source
This commit is contained in:
michael 1998-12-02 12:35:07 +00:00
parent b39d738e62
commit e3e8ca6b98
1 changed files with 151 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

163
rtl/objpas/typinfo.pp
View File

@ -35,6 +35,14 @@ unit typinfo;
PByte =^Byte;
PLongint =^Longint;
PBoolean =^Boolean;
PSingle =^Single;
PDouble =^Double;
PExtended =^Extended;
PComp =^Comp;
PFixed16 =^Fixed16;
{ Doesn't exist ?
PFIxed32 = ^Fixed32;
}
Variant = Pointer;
TMethod = Pointer;
@ -232,6 +240,45 @@ unit typinfo;
// now the result should be in EAX, untested yet (FK)
end;
function CallExtendedFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Extended;assembler;
Label LINoPush;
asm
movl S,%esi
movl Address,%edi
// ? Indexed function
movl Index,%eax
xorl %eax,%eax
jnz LINoPush
movl IValue,%eax
pushl %eax
LINoPush:
call (%edi)
//!! now What ??
end;
function CallExtendedProc(s : Pointer;Address : Pointer;Value : Extended; INdex,IVAlue : Longint) : Integer;assembler;
label LIPNoPush;
asm
movl S,%esi
movl Address,%edi
// Push value to set
//!! MUST BE CHANGED !!
movl Value,%eax
pushl %eax
// ? Indexed procedure
movl Index,%eax
xorl %eax,%eax
jnz LIPNoPush
movl IValue,%eax
pushl %eax
LIPNoPush:
call (%edi)
end;
function CallBooleanFunc(s : Pointer;Address : Pointer; Index,IValue : Longint) : Boolean;assembler;
Label LBNoPush;
@ -478,12 +525,12 @@ unit typinfo;
SetIndexValues(PropInfo,Index,Ivalue);
case (PropInfo^.PropProcs) and 3 of
ptfield:
PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^:=Value;
PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
ptstatic:
CallIntegerProc(Instance,PropInfo^.GetProc,Value,Index,IValue);
CallIntegerProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
ptvirtual:
CallIntegerProc(Instance,
(PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
(PPointer(Instance.ClassType)+Longint(PropInfo^.SetProc)),
Value,Index,IValue);
end;
end;
@ -550,13 +597,45 @@ unit typinfo;
procedure SetAStrProp(Instance : TObject;PropInfo : PPropInfo;
const Value : AnsiString);
begin
end;
{
Dirty trick based on fact that AnsiString is just a pointer,
hence can be treated like an integer type.
}
var
Index,Ivalue : Longint;
begin
SetIndexValues(PropInfo,Index,IValue);
case (PropInfo^.PropProcs) and 3 of
ptfield:
PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Longint(Pointer(Value)) ;
ptstatic:
CallIntegerProc(Instance,PropInfo^.SetProc,Longint(Pointer(Value)),Index,IValue);
ptvirtual:
CallIntegerProc(Instance,
(PPointer(Instance.ClassType)+Longint(PropInfo^.SetProc)),
Longint(Pointer(Value)),Index,IValue);
end;
end;
procedure SetSStrProp(Instance : TObject;PropInfo : PPropInfo;
const Value : AnsiString);
const Value : ShortString);
Var Index,IValue: longint;
begin
SetIndexValues(PRopInfo,Index,IValue);
case (PropInfo^.PropProcs) and 3 of
ptfield:
PShortString(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
ptstatic:
CallSStringProc(Instance,PropInfo^.GetProc,Value,Index,IValue);
ptvirtual:
CallSStringProc(Instance,
(PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
Value,Index,IValue);
end;
end;
procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
@ -571,15 +650,72 @@ unit typinfo;
function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
var
Index,Ivalue : longint;
Value : Extended;
begin
{!!!!!!!!!!!}
SetIndexValues(PropInfo,Index,Ivalue);
case (PropInfo^.PropProcs) and 3 of
ptfield:
Case GetTypeData(PropInfo^.PropType)^.FloatType of
ftSingle:
Value:=PSingle(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
ftDouble:
Value:=PDouble(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
ftExtended:
Value:=PExtended(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
ftcomp:
Value:=PComp(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
{ Uncommenting this code results in a internal error!!
ftFixed16:
Value:=PFixed16(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
ftfixed32:
Value:=PFixed32(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
}
end;
ptstatic:
Value:=CallExtendedFunc(Instance,PropInfo^.GetProc,Index,IValue);
ptvirtual:
Value:=CallExtendedFunc(Instance,
(PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
Index,IValue);
end;
end;
procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
Value : Extended);
begin
{!!!!!!!!!!!}
Var IValue,Index : longint;
begin
SetIndexValues(PropInfo,Index,Ivalue);
case (PropInfo^.PropProcs) and 3 of
ptfield:
Case GetTypeData(PropInfo^.PropType)^.FloatType of
ftSingle:
PSingle(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
ftDouble:
PDouble(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
ftExtended:
PExtended(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
ftcomp:
PComp(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
{ Uncommenting this code results in a internal error!!
ftFixed16:
PFixed16(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
ftfixed32:
PFixed32(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
}
end;
ptstatic:
CallExtendedProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
ptvirtual:
CallExtendedProc(Instance,
(PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
Value,Index,IValue);
end;
end;
function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;
@ -598,7 +734,7 @@ unit typinfo;
function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
begin
{!!!!!!!!!!!}
{!!!!!!!!!!!!}
end;
procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo;
@ -650,7 +786,10 @@ end.
{
$Log$
Revision 1.15 1998-11-26 14:57:47 michael
Revision 1.16 1998-12-02 12:35:07 michael
More changes for type-information
Revision 1.15 1998/11/26 14:57:47 michael
+ Added packrecords 1
Revision 1.11 1998/09/24 23:45:28 peter