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

--- Merging r42809 into '.':

Browse Source 
U    packages/rtl-objpas/tests/tests.rtti.util.pas
--- Recording mergeinfo for merge of r42809 into '.':
 U   .
--- Merging r42810 into '.':
U    packages/rtl-objpas/tests/tests.rtti.pas
G    packages/rtl-objpas/tests/tests.rtti.util.pas
--- Recording mergeinfo for merge of r42810 into '.':
 G   .
--- Recording mergeinfo for merge of r42810 into 'packages/rtl-objpas/tests/tests.rtti.pas':
 U   packages/rtl-objpas/tests/tests.rtti.pas
--- Merging r42988 into '.':
U    compiler/aarch64/racpugas.pas
--- Recording mergeinfo for merge of r42988 into '.':
 G   .
--- Recording mergeinfo for merge of r42988 into 'packages/rtl-objpas/tests/tests.rtti.pas':
 G   packages/rtl-objpas/tests/tests.rtti.pas
--- Merging r42989 into '.':
G    compiler/aarch64/racpugas.pas
--- Recording mergeinfo for merge of r42989 into '.':
 G   .
--- Recording mergeinfo for merge of r42989 into 'packages/rtl-objpas/tests/tests.rtti.pas':
 G   packages/rtl-objpas/tests/tests.rtti.pas
--- Merging r42990 into '.':
U    packages/rtl-objpas/src/inc/rtti.pp
--- Recording mergeinfo for merge of r42990 into '.':
 G   .
--- Recording mergeinfo for merge of r42990 into 'packages/rtl-objpas/tests/tests.rtti.pas':
 G   packages/rtl-objpas/tests/tests.rtti.pas
--- Merging r42991 into '.':
G    packages/rtl-objpas/src/inc/rtti.pp
--- Recording mergeinfo for merge of r42991 into '.':
 G   .
--- Recording mergeinfo for merge of r42991 into 'packages/rtl-objpas/tests/tests.rtti.pas':
 G   packages/rtl-objpas/tests/tests.rtti.pas
--- Merging r43016 into '.':
U    compiler/aarch64/aasmcpu.pas
U    compiler/aarch64/agcpugas.pas
G    compiler/aarch64/racpugas.pas
--- Recording mergeinfo for merge of r43016 into '.':
 G   .
--- Recording mergeinfo for merge of r43016 into 'packages/rtl-objpas/tests/tests.rtti.pas':
 G   packages/rtl-objpas/tests/tests.rtti.pas

# revisions: 42809,42810,42988,42989,42990,42991,43016

git-svn-id: branches/fixes_3_2@43424 -
This commit is contained in:
marco 2019-11-09 13:28:55 +00:00
parent f6d44edc07
commit 4fbb2d9cf0
6 changed files with 57 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/aarch64/aasmcpu.pas
View File

@ -554,16 +554,17 @@ implementation
begin
result:=sr_complex;
if not assigned(ref.symboldata) and
not(ref.refaddr in [addr_gotpageoffset,addr_gotpage,addr_pageoffset,addr_page]) then
not(ref.refaddr in [addr_pic,addr_gotpageoffset,addr_gotpage,addr_pageoffset,addr_page]) then
exit;
{ can't use pre-/post-indexed mode here (makes no sense either) }
if ref.addressmode<>AM_OFFSET then
exit;
{ "ldr literal" must be a 32/64 bit LDR and have a symbol }
if assigned(ref.symboldata) and
if (ref.refaddr=addr_pic) and
((op<>A_LDR) or
not(oppostfix in [PF_NONE,PF_W,PF_SW]) or
not assigned(ref.symbol)) then
(not assigned(ref.symbol) and
not assigned(ref.symboldata))) then
exit;
{ if this is a (got) page offset load, we must have a base register and a
symbol }

6
compiler/aarch64/agcpugas.pas
View File

@ -119,9 +119,11 @@ unit agcpugas;
result:=ref.symbol.name+darwin_addrpage2str[ref.refaddr]
else
result:=linux_addrpage2str[ref.refaddr]+ref.symbol.name
end
end;
addr_pic:
result:=ref.symbol.name;
else
internalerror(2015022301);
internalerror(2015022302);
end
end
else

3
compiler/aarch64/racpugas.pas
View File

@ -563,7 +563,8 @@ Unit racpugas;
oper.opr.symbol:=hl;
end
else if (actopcode=A_ADR) or
(actopcode=A_ADRP) then
(actopcode=A_ADRP) or
(actopcode=A_LDR) then
begin
oper.InitRef;
MaybeAddGotAddrMode;

26
packages/rtl-objpas/src/inc/rtti.pp
View File

@ -921,6 +921,26 @@ asm
.long RawThunkPlaceholderContext
RawThunkEnd:
end;
{$elseif defined(cpuaarch64)}
const
RawThunkPlaceholderProc = $8765876587658765;
RawThunkPlaceholderContext = $4321432143214321;
type
TRawThunkProc = PtrUInt;
TRawThunkContext = PtrUInt;
procedure RawThunk; assembler; nostackframe;
asm
ldr x16, .LProc
ldr x0, .LContext
br x16
.LProc:
.quad RawThunkPlaceholderProc
.LContext:
.quad RawThunkPlaceholderContext
RawThunkEnd:
end;
{$elseif defined(cpum68k)}
const
RawThunkPlaceholderProc = $87658765;
@ -986,7 +1006,7 @@ begin
{$if declared(TRawThunkBytesToPop)}
if not btpdone and (i <= Size - SizeOf(TRawThunkBytesToPop)) then begin
btp := PRawThunkBytesToPop(PByte(Result) + i);
if btp^ = RawThunkPlaceholderBytesToPop then begin
if btp^ = TRawThunkBytesToPop(RawThunkPlaceholderBytesToPop) then begin
btp^ := TRawThunkBytesToPop(aBytesToPop);
btpdone := True;
end;
@ -994,14 +1014,14 @@ begin
{$endif}
if not contextdone and (i <= Size - SizeOf(TRawThunkContext)) then begin
context := PRawThunkContext(PByte(Result) + i);
if context^ = RawThunkPlaceholderContext then begin
if context^ = TRawThunkContext(RawThunkPlaceholderContext) then begin
context^ := TRawThunkContext(aContext);
contextdone := True;
end;
end;
if not procdone and (i <= Size - SizeOf(TRawThunkProc)) then begin
proc := PRawThunkProc(PByte(Result) + i);
if proc^ = RawThunkPlaceholderProc then begin
if proc^ = TRawThunkProc(RawThunkPlaceholderProc) then begin
proc^ := TRawThunkProc(aProc);
procdone := True;
end;

23
packages/rtl-objpas/tests/tests.rtti.pas
View File

@ -94,6 +94,9 @@ type
implementation
uses
Tests.Rtti.Util;
type
{$M+}
@ -1788,7 +1791,7 @@ begin
method := methods[0];
CheckEquals(method.Name, 'Test', 'Method name of Test does not match');
Check(method.CallingConvention = ccReg, 'Calling convention of Test does not match');
Check(method.CallingConvention = DefaultCC, 'Calling convention of Test does not match');
Check(method.MethodKind = mkProcedure, 'Method kind of Test does not match');
Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test does not match');
Check(not Assigned(method.CodeAddress), 'Code address of Test is not Nil');
@ -1799,7 +1802,7 @@ begin
method := methods[1];
CheckEquals(method.Name, 'Test2', 'Method name of Test2 does not match');
Check(method.CallingConvention = ccReg, 'Calling convention of Test2 does not match');
Check(method.CallingConvention = DefaultCC, 'Calling convention of Test2 does not match');
Check(method.MethodKind = mkFunction, 'Method kind of Test2 does not match');
Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test2 does not match');
Check(not Assigned(method.CodeAddress), 'Code address of Test2 is not Nil');
@ -1811,7 +1814,7 @@ begin
method := methods[2];
CheckEquals(method.Name, 'Test3', 'Method name of Test3 does not match');
Check(method.CallingConvention = ccReg, 'Calling convention of Test3 does not match');
Check(method.CallingConvention = DefaultCC, 'Calling convention of Test3 does not match');
Check(method.MethodKind = mkProcedure, 'Method kind of Test3 does not match');
Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test3 does not match');
Check(not Assigned(method.CodeAddress), 'Code address of Test3 is not Nil');
@ -1847,7 +1850,7 @@ begin
method := methods[3];
CheckEquals(method.Name, 'Test4', 'Method name of Test4 does not match');
Check(method.CallingConvention = ccReg, 'Calling convention of Test4 does not match');
Check(method.CallingConvention = DefaultCC, 'Calling convention of Test4 does not match');
Check(method.MethodKind = mkFunction, 'Method kind of Test4 does not match');
Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test4 does not match');
Check(not Assigned(method.CodeAddress), 'Code address of Test4 is not Nil');
@ -1929,7 +1932,7 @@ begin
Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
p := t as TRttiProcedureType;
Check(p.CallingConvention = ccReg, 'Calling convention does not match');
Check(p.CallingConvention = DefaultCC, 'Calling convention does not match');
Check(not Assigned(p.ReturnType), 'Return type is assigned');
CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
@ -1939,7 +1942,7 @@ begin
Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
p := t as TRttiProcedureType;
Check(p.CallingConvention = ccReg, 'Calling convention does not match');
Check(p.CallingConvention = DefaultCC, 'Calling convention does not match');
Check(Assigned(p.ReturnType), 'Return type is not assigned');
//Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
@ -1950,7 +1953,7 @@ begin
Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
p := t as TRttiProcedureType;
Check(p.CallingConvention = ccReg, 'Calling convention does not match');
Check(p.CallingConvention = DefaultCC, 'Calling convention does not match');
Check(Assigned(p.ReturnType), 'Return type is not assigned');
Check(p.ReturnType is TRttiStringType, 'Return type is not a string type');
@ -1981,7 +1984,7 @@ begin
Check(t is TRttiMethodType, 'Rtti Type is not a method type');
m := t as TRttiMethodType;
Check(m.CallingConvention = ccReg, 'Calling convention does not match');
Check(m.CallingConvention = DefaultCC, 'Calling convention does not match');
Check(not Assigned(m.ReturnType), 'Return type is assigned');
CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
@ -1991,7 +1994,7 @@ begin
Check(t is TRttiMethodType, 'Rtti Type is not a method type');
m := t as TRttiMethodType;
Check(m.CallingConvention = ccReg, 'Calling convention does not match');
Check(m.CallingConvention = DefaultCC, 'Calling convention does not match');
Check(Assigned(m.ReturnType), 'Return type is not assigned');
//Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
@ -2002,7 +2005,7 @@ begin
Check(t is TRttiMethodType, 'Rtti Type is not a method type');
m := t as TRttiMethodType;
Check(m.CallingConvention = ccReg, 'Calling convention does not match');
Check(m.CallingConvention = DefaultCC, 'Calling convention does not match');
Check(Assigned(m.ReturnType), 'Return type is not assigned');
Check(m.ReturnType is TRttiStringType, 'Return type is not a string type');

13
packages/rtl-objpas/tests/tests.rtti.util.pas
View File

@ -5,7 +5,7 @@ unit Tests.Rtti.Util;
interface
uses
Rtti;
TypInfo, Rtti;
{$ifndef fpc}
type
@ -17,6 +17,13 @@ type
end;
{$endif}
const
{$if defined(cpui386) or defined(cpux86_64) or defined(cpum68k)}
DefaultCC = ccReg;
{$else}
DefaultCC = ccStdCall;
{$endif}
function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
function EqualValues({$ifdef fpc}constref{$else}const [ref]{$endif} aValue1, aValue2: TValue): Boolean;
@ -37,7 +44,7 @@ function GetArray(const aArg: array of SizeInt): TValue;
implementation
uses
TypInfo, SysUtils, Math;
SysUtils, Math;
{$ifndef fpc}
function TValueHelper.AsUnicodeString: UnicodeString;
@ -90,7 +97,9 @@ begin
Result := True;
for i := 0 to aValue1.GetArrayLength - 1 do
if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
{$ifdef debug}
Writeln('Element ', i, ' differs: ', HexStr(aValue1.GetArrayElement(i).AsOrdinal, 4), ' ', HexStr(aValue2.GetArrayElement(i).AsOrdinal, 4));
{$endif}
Result := False;
Break;
end;