path: root/fpcsrc/tests/test/opt/tretopt.pp

{$mode objfpc}
{$inline on}

type
  pshortstring=^shortstring;

  tr = record
    a,b,c,d,e: shortstring;
  end;

  ta = array[0..5] of shortstring;

  tc = record
    p: pointer;
  end;

var
  p,p2,p3: pointer;
  inlined, failed: boolean;

procedure error(err: longint);
begin
  writeln('error near ',err, ' (inlined: ',inlined,')');
  failed:=true;
end;

function f1(p: pchar): tr;
begin
  fillchar(result,sizeof(tr),0);
  if (p^<>'x') then
    error(1);
  f1.a:=p^;
end;


function f2(var s: shortstring): tr;
begin
  fillchar(result,sizeof(tr),0);
  if (s<>'x') then
    error(2);
  f2.a:=s;
end;


function f3(const s: shortstring): tr;
begin
  fillchar(result,sizeof(tr),0);
  if (s<>'x') then
    error(3);
  f3.a:=s;
end;


function f4(const t: tr): tr;
begin
  fillchar(result,sizeof(tr),0);
  if (t.a<>'x') then
    error(4);
  f4:=t;
end;



function f5(p: pchar): ta;
begin
  fillchar(result,sizeof(result),0);
  if (p^<>'x') then
    error(5);
  result[3]:=p^;
end;


function f6(var s: shortstring): ta;
begin
  fillchar(result,sizeof(result),0);
  if (s<>'x') then
    error(6);
  result[3]:=s;
end;


function f7(const s: shortstring): ta;
begin
  fillchar(result,sizeof(result),0);
  if (s<>'x') then
    error(7);
  result[3]:=s;
end;


function f8(const t: ta): ta;
begin
  fillchar(result,sizeof(result),0);
  if (t[3]<>'x') then
    error(8);
  result:=t;
end;


procedure temp;
begin
  if (pshortstring(p)^<>'x') then
    error(9);
end;

function f9: tr;
begin
  fillchar(result,sizeof(result),0);
  temp;
  result.a:='x';
end;

procedure temp2(var a);
begin
  p2:=@a;
end;

function f10: tr;
begin
  fillchar(result,sizeof(result),0);
  if (pshortstring(p2)^<>'x') then
    error(10);
  result.a:='x';
end;

procedure testrec1;
var
  t: tr;
begin
  t.a:='x';
  t:=f1(@t.a[1]);
end;


procedure testrec2;
var
  t: tr;
begin
  t.a:='x';
  t:=f2(t.a);
end;


procedure testrec3;
var
  t: tr;
begin
  t.a:='x';
  t:=f3(t.a);
end;


procedure testrec4;
var
  t: tr;
begin
  t.a:='x';
  t:=f4(t);
end;


procedure testrec5;
var
  t: tr;
begin
  t.a:='x';
  p:=@t.a;
  t:=f9;
end;


procedure testrecinl1; inline;
var
  t: tr;
begin
  inlined:=true;
  t.a:='x';
  t:=f1(@t.a[1]);
end;


procedure testrecinl2; inline;
var
  t: tr;
begin
  inlined:=true;
  t.a:='x';
  t:=f2(t.a);
end;


procedure testrecinl3; inline;
var
  t: tr;
begin
  inlined:=true;
  t.a:='x';
  t:=f3(t.a);
end;


procedure testrecinl4; inline;
var
  t: tr;
begin
  inlined:=true;
  t.a:='x';
  t:=f4(t);
end;


procedure testrecinl5; inline;
var
  t: tr;
begin
  inlined:=true;
  t.a:='x';
  p:=@t.a;
  t:=f9;
  inlined:=false;
end;


procedure testrec2a;
var
  t: tr;
begin
  t.a:='x';
  temp2(t.a);
  t:=f10;
end;


procedure testrec2ainl; inline;
var
  t: tr;
begin
  inlined:=true;
  t.a:='x';
  temp2(t.a);
  t:=f10;
  inlined:=false;
end;


{$if defined(cpupowerpc32) or defined(cpupowerpc64) or defined(cpui386)}
function f11: tr;
begin
  fillchar(result,sizeof(result),0);
  if (pshortstring(p3)^<>'x') then
    error(11);
  result.a:='x';
end;

procedure testrec3a;
var
  t: tr;
begin
  asm
{$ifdef cpupowerpc32}
    la  r3,t
  {$ifndef macos}
    lis  r4,p3@ha
    addi r4,r4,p3@l
  {$else}
    lwz  r4,p3(r2)
  {$endif}
    stw  r3,0(r4)
{$endif}
{$ifdef cpupowerpc64}
    la  r3,t
{$ifndef darwin}
    lis  r4, p3@highesta
    ori  r4, r4, p3@highera
    sldi r4, r4, 32
    oris r4, r4, p3@ha
{$else darwin}
    lis  r4, p3@ha
{$endif darwin}
    std  r3,p3@l(r4)
{$endif}
{$ifdef cpui386}
    leal t,%eax
{$ifndef FPC_PIC}
    movl %eax,p3
{$else FPC_PIC}
    call .Lpic
.Lpic:
    popl %ecx
{$ifdef darwin}
    movl %eax,p3-.Lpic(%ecx)
{$else darwin}
   addl $_GLOBAL_OFFSET_TABLE_,%ecx
   movl %eax,p3@GOT(%ecx)
{$endif darwin}
{$endif FPC_PIC}
{$endif cpui386}
  end;

  t.a:='x';
  t:=f11;
end;


procedure testrec3ainl; inline;
var
  t: tr;
begin
  inlined:=true;
  asm
{$ifdef cpupowerpc32}
    la  r3,t
  {$ifndef macos}
    lis  r4,p3@ha
    addi r4,r4,p3@l
  {$else}
    lwz  r4,p3(r2)
  {$endif}
    stw  r3,0(r4)
{$endif}
{$ifdef cpupowerpc64}
    la  r3,t
{$ifndef darwin}
    lis  r4, p3@highesta
    ori  r4, r4, p3@highera
    sldi r4, r4, 32
    oris r4, r4, p3@ha
{$else darwin}
    lis  r4, p3@ha
{$endif darwin}
    std  r3,p3@l(r4)
{$endif}
{$ifdef cpui386}
    leal t,%eax
{$ifndef FPC_PIC}
    movl %eax,p3
{$else FPC_PIC}
    call .Lpic
.Lpic:
    popl %ecx
{$ifdef darwin}
    movl %eax,p3-.Lpic(%ecx)
{$else darwin}
   addl $_GLOBAL_OFFSET_TABLE_,%ecx
   movl %eax,p3@GOT(%ecx)
{$endif darwin}
{$endif FPC_PIC}
{$endif}
  end;

  t.a:='x';
  t:=f11;
  inlined:=false;
end;

{$endif}



procedure testarr1;
var
  t: ta;
begin
  t[3]:='x';
  t:=f5(@t[3][1]);
end;


procedure testarr2;
var
  t: ta;
begin
  t[3]:='x';
  t:=f6(t[3]);
end;


procedure testarr3;
var
  t: ta;
begin
  t[3]:='x';
  t:=f7(t[3]);
end;


procedure testarr4;
var
  t: ta;
begin
  t[3]:='x';
  t:=f8(t);
end;


procedure testarrinl1; inline;
var
  t: ta;
begin
  inlined:=true;
  t[3]:='x';
  t:=f5(@t[3][1]);
end;


procedure testarrinl2; inline;
var
  t: ta;
begin
  inlined:=true;
  t[3]:='x';
  t:=f6(t[3]);
end;


procedure testarrinl3; inline;
var
  t: ta;
begin
  inlined:=true;
  t[3]:='x';
  t:=f7(t[3]);
end;


procedure testarrinl4; inline;
var
  t: ta;
begin
  inlined:=true;
  t[3]:='x';
  t:=f8(t);
  inlined:=false;
end;


begin
  testrec1;
  testrec2;
  testrec3;
  testrec4;
  testrec5;
  testrecinl1;
  testrecinl2;
  testrecinl3;
  testrecinl4;
  testrecinl5;
  testrec2a;
  testrec2ainl;
{$if defined(cpupowerpc32) or defined(cpui386) or defined(cpupowerpc64)}
  testrec3a;
  testrec3ainl;
{$endif}
  testarr1;
  testarr2;
  testarr3;
  testarr4;
  testarrinl1;
  testarrinl2;
  testarrinl3;
  testarrinl4;
  if failed then
    halt(1);
end.