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

* fcl-fpcunit/src/testutils.pp, GetMethodList: avoid range errors at runtime if compiled with -Cr.

Browse Source 
git-svn-id: trunk@20646 -
This commit is contained in:
sergei 2012-03-28 10:55:17 +00:00
parent bab72f0025
commit 8b40abdd19
1 changed files with 6 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
packages/fcl-fpcunit/src/testutils.pp
View File

@ -64,6 +64,7 @@ end;
procedure GetMethodList(AClass: TClass; AList: TStrings);
type
PMethodNameRec = ^TMethodNameRec;
TMethodNameRec = packed record
name : pshortstring;
addr : pointer;
@ -81,6 +82,7 @@ var
i : dword;
vmt: TClass;
idx: integer;
pmr: PMethodNameRec;
begin
AList.Clear;
vmt := aClass;
@ -89,13 +91,15 @@ begin
methodTable := pMethodNameTable((Pointer(vmt) + vmtMethodTable)^);
if assigned(MethodTable) then
begin
pmr := @methodTable^.entries[0];
for i := 0 to MethodTable^.count - 1 do
begin
idx := aList.IndexOf(MethodTable^.entries[i].name^);
idx := aList.IndexOf(pmr^.name^);
if (idx <> - 1) then
//found overridden method so delete it
aList.Delete(idx);
aList.AddObject(MethodTable^.entries[i].name^, TObject(MethodTable^.entries[i].addr));
aList.AddObject(pmr^.name^, TObject(pmr^.addr));
Inc(pmr);
end;
end;
vmt := pClass(pointer(vmt) + vmtParent)^;