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

Fix test for msdos targets

Browse Source 
git-svn-id: trunk@36229 -
This commit is contained in:
pierre 2017-05-16 20:36:49 +00:00
parent 9517fbe7f6
commit 78361f5900
1 changed files with 64 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
tests/webtbs/tw16034.pp
View File

@ -7,6 +7,25 @@ program Hello;
{$APPTYPE CONSOLE}
{$O-}
const
val_O0 = 35;
val_O1 = 74;
val_O2 = 123;
{$ifdef CPUI8086}
const
offset_size = 4;
type
Int = smallint;
UInt = word;
{$else}
const
offset_size = 2*sizeof(pointer);
type
Int = ptrint;
UInt = ptruint;
{$endif}
type
ptr = pointer;
{$ifdef fpc}
@ -14,9 +33,9 @@ type
{$else}
codeptr = pointer;
{$endif}
Int = ptrint;
pPtr = ^ptr;
UInt = ptruint;
Bool = Boolean;
// Object woth VMT at offset 0.
@ -52,7 +71,7 @@ enD;
Function TObj0.Value(p: UInt): UInt;
begin
Result := 0;
Result := val_O0;
enD;
Constructor TObj1.Init;
@ -61,7 +80,7 @@ enD;
Function TObj1.Value(p: UInt): UInt;
begin
Result := 0;
Result := val_O1;
enD;
Constructor TObj2.Init;
@ -70,7 +89,7 @@ enD;
Function TObj2.Value(p: UInt): UInt;
begin
Result := 0;
Result := val_O2;
enD;
{ Low Level VMT Routines }
@ -92,17 +111,27 @@ enD;
Function GetVMTPtrOffset(AVMT: pObjVMT): UInt;
begin
writeln('AVMT is ',hexstr(seg(AVMT^),4),':',hexstr(ofs(AVMT^),offset_size));
writeln('AVMT^.fParent is ',hexstr(seg(AVMT^.fParent^),4),':',hexstr(ofs(AVMT^.fParent^),offset_size));
if (AVMT.fParent = nil) then
Result := GetInstanceSize(AVMT) - SizeOf(ptr) else
Result := GetVMTPtrOffset(AVMT.fParent^);
writeln('GetVMTPtrOffset=',hexstr(Result,2*sizeof(UInt)));
enD;
Function SetVMT(Obj: ptr; AVMT: ptr): Bool;
var
p : pptr;
begin
Result := (AVMT <> nil);
if (Result) then
pPtr(UInt(Obj) + GetVMTPtrOffset(AVMT))^ := AVMT;
begin
writeln('Obj is ',hexstr(seg(Obj^),4),':',hexstr(ofs(Obj^),offset_size));
p:=pPtr(ptr(Obj) + GetVMTPtrOffset(AVMT));
writeln('Setting p ',hexstr(seg(p^),4),':',hexstr(ofs(p^),offset_size),' to ',hexstr(seg(AVMT^),4),':',hexstr(ofs(AVMT^),offset_size));
p^ := AVMT;
end;
enD;
@ -116,12 +145,15 @@ var
s0, s1, s2: UInt;
v0, v1, v2: ptr;
cn0, cn1, cn2: codeptr;
st : string;
begin
// VMT Pointers
v0 := TypeOf(TObj0);
v1 := TypeOf(TObj1);
v2 := TypeOf(TObj2);
writeln('TObj0 VMT ',hexstr(seg(v0^),4),':',hexstr(ofs(v0^),offset_size));
writeln('TObj1 VMT ',hexstr(seg(v1^),4),':',hexstr(ofs(v1^),offset_size));
writeln('TObj2 VMT ',hexstr(seg(v2^),4),':',hexstr(ofs(v2^),offset_size));
// Object sizes
s0 := SizeOf(TObj0); // = 4
@ -148,19 +180,37 @@ begin
O2.Init;
}
writeln('@TObj0.Value ',hexstr(seg(cn0^),4),':',hexstr(ofs(cn0^),offset_size));
writeln('@TObj1.Value ',hexstr(seg(cn1^),4),':',hexstr(ofs(cn1^),offset_size));
writeln('@TObj2.Value ',hexstr(seg(cn2^),4),':',hexstr(ofs(cn2^),offset_size));
// Store VMT (emulate constructor)
SetVMT(@O0, TypeOf(TObj0));
SetVMT(@O1, TypeOf(TObj1));
SetVMT(@O2, TypeOf(TObj2));
// Call Virtual Functions
O2.f1 := O0.Value(0);
O2.f1 := O1.Value(0);
O2.f1 := O2.Value(0); {CRASHES !!!}
{ SizeOf(TObj2) must be 5,
or ptr(Int(@o2._vptr$) - Int(@o2)) must be 4! }
// readln(st);
st:='c';
// MessageBox will be displayed, if all was successfull
if st='c' then
begin
writeln('O0 value is ',O0.VAlue(0),' after O0');
writeln('O1 value is ',O1.VAlue(0),' after O1');
writeln('O2 value is ',O2.VAlue(0),' after O2');
// Call Virtual Functions
O2.f1 := O0.Value(0);
if O2.f1<>val_O0 then
halt(1);
O2.f1 := O1.Value(0);
if O2.f1<>val_O1 then
halt(2);
O2.f1 := O2.Value(0); {CRASHES !!!}
if O2.f1<>val_O2 then
halt(3);
{ SizeOf(TObj2) must be 5,
or ptr(Int(@o2._vptr$) - Int(@o2)) must be 4! }
// MessageBox will be displayed, if all was successfull
end;
writeln(O2.f1, 'Hello, FPC uWorld!', 'Hello', 0);
end.