tests: started test suite for compiling and using ppus

tests/tppu/.gitignore

@@ -0,0 +1,2 @@
+testppu
+testppu.app

tests/tppu/implinline1/implinline1_ant.pas

@@ -0,0 +1,18 @@
+unit implinline1_ant;
+
+{$mode objfpc}
+
+interface
+
+uses implinline1_bird;
+
+function Times123(w : word): word;
+
+implementation
+
+function Times123(w : word): word; inline;
+begin
+   Result := w*123;
+end;
+
+end.

tests/tppu/implinline1/implinline1_bird.pas

@@ -0,0 +1,18 @@
+unit implinline1_bird;
+
+{$mode objfpc}
+
+interface
+
+procedure Walk;
+
+implementation
+
+uses implinline1_ant;
+
+procedure Walk;
+begin
+  writeln(Times123(2));
+end;
+
+end.

tests/tppu/tcrecompile.pas

@@ -0,0 +1,258 @@
+unit tcrecompile;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit, testregistry, tstppuutils;
+
+type
+
+  { TTestRecompile }
+
+  TTestRecompile = class(TTestCase)
+  private
+    FCompiled: TStringList;
+    FMainSrc: string;
+    FOutDir: string;
+    FPP: string;
+    FStep: string;
+    FUnitPath: string;
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+    procedure CleanOutputDir; overload;
+    procedure CleanOutputDir(Dir: string); overload;
+    procedure Compile;
+    procedure CheckCompiled(const Expected: TStringArray);
+    property PP: string read FPP write FPP;
+    property UnitPath: string read FUnitPath write FUnitPath;
+    property OutDir: string read FOutDir write FOutDir;
+    property MainSrc: string read FMainSrc write FMainSrc;
+    property Compiled: TStringList read FCompiled write FCompiled;
+    property Step: string read FStep write FStep;
+  public
+    constructor Create; override;
+    procedure GetCompiler;
+    procedure CheckCompiler;
+  published
+    procedure TestTwoUnits;
+    procedure TestImplInline1;
+  end;
+
+
+implementation
+
+
+{ TTestRecompile }
+
+procedure TTestRecompile.SetUp;
+begin
+  inherited SetUp;
+  UnitPath:='';
+  OutDir:='';
+  MainSrc:='';
+end;
+
+procedure TTestRecompile.TearDown;
+begin
+  FreeAndNil(FCompiled);
+  inherited TearDown;
+end;
+
+procedure TTestRecompile.CleanOutputDir;
+begin
+  CleanOutputDir(OutDir);
+end;
+
+procedure TTestRecompile.CleanOutputDir(Dir: string);
+var
+  Info: TRawByteSearchRec;
+  Filename: String;
+  r: LongInt;
+begin
+  if Dir='' then
+    Fail('TTestRecompile.CleanOutputDir: missing Dir');
+  if Dir[length(Dir)]=PathDelim then
+    Delete(Dir,length(Dir),1);
+
+  if not DirectoryExists(Dir) then
+    if not CreateDir(Dir) then
+      Fail('unable to create output directory "'+Dir+'"');
+
+  writeln('CleanOutputDir ',Dir);
+  r:=FindFirst(Dir+PathDelim+AllFilesMask,faAnyFile,Info);
+  try
+    if r<>0 then exit;
+    repeat
+      case Info.Name of
+      '','.','..': continue;
+      end;
+      if faDirectory and Info.Attr>0 then
+        continue; // keep directories
+      if Info.Name[1]='.' then
+        continue; // keep hidden files
+      case lowercase(ExtractFileExt(Info.Name)) of
+      '.txt': continue; // keep txt files
+      end;
+
+      Filename:=Dir+PathDelim+Info.Name;
+      if not DeleteFile(Filename) then
+        Fail('unable to delete "'+Filename+'"');
+    until FindNext(Info)<>0;
+  finally
+    FindClose(Info);
+  end;
+end;
+
+procedure TTestRecompile.Compile;
+var
+  Params, Lines: TStringList;
+  i: Integer;
+  Line, Filename: String;
+begin
+  if UnitPath='' then
+    Fail('missing UnitPath, Step='+Step);
+
+  if OutDir='' then
+    Fail('missing OutDir, Step='+Step);
+  if not DirectoryExists(OutDir) then
+    Fail('OutDir not found "'+OutDir+'", Step='+Step);
+
+  if MainSrc='' then
+    Fail('missing MainSrc, Step='+Step);
+  if not FileExists(MainSrc) then
+    Fail('main src file not found "'+MainSrc+'", Step='+Step);
+
+  Lines:=nil;
+  Compiled:=TStringList.Create;
+  Params:=TStringList.Create;
+  try
+    Params.Add('-Fu'+UnitPath);
+    Params.Add('-FE'+OutDir);
+    Params.Add(MainSrc);
+    if not RunTool(PP,Params,'',false,true,Lines) then
+      Fail('compile failed, Step='+Step);
+
+    for i:=0 to Lines.Count-1 do
+    begin
+      Line:=Lines[i];
+      if LeftStr(Line,length('Compiling '))='Compiling ' then
+      begin
+        Filename:=copy(Line,length('Compiling ')+1,length(Line));
+        writeln('Compiling: ',Filename);
+        Filename:=ExtractFileName(Filename);
+        if Compiled.IndexOf(Filename)<0 then
+          Compiled.Add(Filename);
+      end;
+    end;
+  finally
+    Lines.Free;
+    Params.Free;
+  end;
+end;
+
+procedure TTestRecompile.CheckCompiled(const Expected: TStringArray);
+var
+  i, j: Integer;
+begin
+  for i:=0 to length(Expected)-1 do
+    if Compiled.IndexOf(Expected[i])<0 then
+      Fail('missing compiling "'+Expected[i]+'", Step='+Step);
+  for i:=0 to Compiled.Count-1 do
+  begin
+    j:=length(Expected)-1;
+    while (j>=0) and (Expected[j]<>Compiled[i]) do dec(j);
+    if j<0 then
+      Fail('unexpected compiling "'+Compiled[i]+'", Step='+Step);
+  end;
+end;
+
+constructor TTestRecompile.Create;
+begin
+  inherited Create;
+
+  GetCompiler;
+end;
+
+procedure TTestRecompile.GetCompiler;
+const
+  CompilerParam = '--compiler=';
+var
+  i: Integer;
+  aParam: String;
+begin
+  for i:=1 to ParamCount do
+  begin
+    aParam:=ParamStr(i);
+    if LeftStr(aParam,length(CompilerParam))=CompilerParam then
+    begin
+      PP:=copy(aParam,length(CompilerParam)+1,255);
+      CheckCompiler;
+      exit;
+    end;
+  end;
+
+  PP:=GetEnvironmentVariable(String('PP'));
+  if PP>'' then
+  begin
+    CheckCompiler;
+    exit;
+  end;
+
+  raise Exception.Create('I need either environment var "PP" or cmd line param "compiler"');
+end;
+
+procedure TTestRecompile.CheckCompiler;
+
+  procedure E(Msg: string);
+  begin
+    writeln('TTestRecompile.CheckCompiler: '+Msg);
+    raise Exception.Create('TTestRecompile.CheckCompiler: '+Msg);
+  end;
+
+begin
+  if PP='' then
+    E('missing compiler');
+  if not FileIsExecutable(PP) then
+    E('compiler not executable: "'+PP+'"');
+end;
+
+procedure TTestRecompile.TestTwoUnits;
+begin
+  UnitPath:='twounits';
+  OutDir:='twounits'+PathDelim+'ppus';
+  MainSrc:='twounits'+PathDelim+'tppu_twounits_ant.pas';
+
+  Step:='First compile';
+  CleanOutputDir;
+  Compile;
+  CheckCompiled(['tppu_twounits_ant.pas','tppu_twounits_bird.pas']);
+
+  Step:='Second compile';
+  Compile;
+  CheckCompiled(['tppu_twounits_ant.pas']);
+end;
+
+procedure TTestRecompile.TestImplInline1;
+begin
+  UnitPath:='implinline1';
+  OutDir:='implinline1'+PathDelim+'ppus';
+  MainSrc:='implinline1'+PathDelim+'implinline1_ant.pas';
+
+  Step:='First compile';
+  CleanOutputDir;
+  Compile;
+  CheckCompiled(['implinline1_ant.pas','implinline1_bird.pas']);
+
+  Step:='Second compile';
+  Compile;
+  CheckCompiled(['implinline1_ant.pas']);
+end;
+
+initialization
+  RegisterTests([TTestRecompile]);
+
+end.
+

tests/tppu/testppu.lpi

@@ -0,0 +1,95 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <General>
+      <Flags>
+        <SaveOnlyProjectUnits Value="True"/>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+        <SaveJumpHistory Value="False"/>
+        <SaveFoldState Value="False"/>
+        <CompatibilityMode Value="True"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+      <Modes Count="1">
+        <Mode0 Name="default"/>
+      </Modes>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="FCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="3">
+      <Unit0>
+        <Filename Value="testppu.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="tcrecompile.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="tstppuutils.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit2>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="testppu"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+    </SearchPaths>
+    <Parsing>
+      <SyntaxOptions>
+        <AllowLabel Value="False"/>
+      </SyntaxOptions>
+    </Parsing>
+    <CodeGeneration>
+      <Checks>
+        <IOChecks Value="True"/>
+        <RangeChecks Value="True"/>
+        <OverflowChecks Value="True"/>
+        <StackChecks Value="True"/>
+      </Checks>
+      <VerifyObjMethodCallValidity Value="True"/>
+    </CodeGeneration>
+    <Linking>
+      <Debugging>
+        <DebugInfoType Value="dsDwarf3"/>
+      </Debugging>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

tests/tppu/testppu.lpr

@@ -0,0 +1,30 @@
+program testppu;
+
+{$mode objfpc}{$H+}
+
+uses
+{$IFDEF UNIX}
+  cwstring,
+{$ENDIF}
+  Classes, consoletestrunner, tcrecompile, tstppuutils;
+
+type
+
+  { TLazTestRunner }
+
+  TMyTestRunner = class(TTestRunner)
+  protected
+  // override the protected methods of TTestRunner to customize its behavior
+  end;
+
+var
+  Application: TMyTestRunner;
+
+begin
+  Application := TMyTestRunner.Create(nil);
+  DefaultFormat:=fplain;
+  DefaultRunAllTests:=True;
+  Application.Initialize;
+  Application.Run;
+  Application.Free;
+end.

tests/tppu/tstppuutils.pas

@@ -0,0 +1,106 @@
+unit tstppuutils;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Process;
+
+function FileIsExecutable(const AFilename: string): boolean;
+function RunTool(const Filename: string; Params: TStrings;
+  WorkingDirectory: string; Quiet, WriteOnError: boolean; out Lines: TStringList): boolean;
+
+implementation
+
+{$IFDEF Unix}
+uses BaseUnix;
+{$ENDIF}
+
+function FileIsExecutable(const AFilename: string): boolean;
+{$IFDEF Unix}
+var
+  Info : Stat;
+begin
+  // first check AFilename is not a directory and then check if executable
+  Result:= (FpStat(AFilename,info{%H-})<>-1) and FPS_ISREG(info.st_mode)
+       and (BaseUnix.FpAccess(AFilename,BaseUnix.X_OK)=0);
+end;
+{$ELSE}
+begin
+  Result:=FileExists(AFilename);
+end;
+{$ENDIF}
+
+function RunTool(const Filename: string; Params: TStrings;
+  WorkingDirectory: string; Quiet, WriteOnError: boolean; out Lines: TStringList): boolean;
+var
+  buf: string;
+  TheProcess: TProcess;
+  OutputLine: String;
+  OutLen: Integer;
+  LineStart, i: Integer;
+begin
+  Result:=false;
+  Lines:=nil;
+  if not FileIsExecutable(Filename) then
+    raise Exception.Create('Compiler not executable: "'+Filename+'"');
+  if (WorkingDirectory<>'') and not DirectoryExists(WorkingDirectory) then
+    raise Exception.Create('WorkingDirectory not found "'+WorkingDirectory+'"');
+  Lines:=TStringList.Create;
+  buf:='';
+  if (MainThreadID=GetCurrentThreadId) and not Quiet then begin
+    write('Hint: RunTool: "',Filename,'"');
+    for i:=0 to Params.Count-1 do
+      write(' "',Params[i],'"');
+    if WorkingDirectory<>'' then
+      write(', WorkDir="',WorkingDirectory,'"');
+    writeln;
+  end;
+  TheProcess := TProcess.Create(nil);
+  try
+    TheProcess.Executable := Filename;
+    TheProcess.Parameters:=Params;
+    TheProcess.Options:= [poUsePipes, poStdErrToOutPut];
+    TheProcess.ShowWindow := swoHide;
+    TheProcess.CurrentDirectory:=WorkingDirectory;
+    TheProcess.Execute;
+    OutputLine:='';
+    SetLength(buf,4096);
+    repeat
+      if (TheProcess.Output<>nil) then begin
+        OutLen:=TheProcess.Output.Read(Buf[1],length(Buf));
+      end else
+        OutLen:=0;
+      LineStart:=1;
+      i:=1;
+      while i<=OutLen do begin
+        if Buf[i] in [#10,#13] then begin
+          OutputLine:=OutputLine+copy(Buf,LineStart,i-LineStart);
+          Lines.Add(OutputLine);
+          OutputLine:='';
+          if (i<OutLen) and (Buf[i+1] in [#10,#13]) and (Buf[i]<>Buf[i+1])
+          then
+            inc(i);
+          LineStart:=i+1;
+        end;
+        inc(i);
+      end;
+      OutputLine:=OutputLine+copy(Buf,LineStart,OutLen-LineStart+1);
+    until OutLen=0;
+    if OutputLine<>'' then
+      Lines.Add(OutputLine);
+    TheProcess.WaitOnExit;
+    Result:=(TheProcess.ExitCode=0) and (TheProcess.ExitStatus=0);
+  finally
+    if not Result and WriteOnError then
+    begin
+      for i:=0 to Lines.Count-1 do
+        writeln(Lines[i]);
+    end;
+    TheProcess.Free;
+  end;
+end;
+
+end.
+

tests/tppu/twounits/tppu_twounits_ant.pas

@@ -0,0 +1,18 @@
+unit tppu_twounits_ant;
+
+{$mode objfpc}
+
+interface
+
+uses tppu_twounits_bird;
+
+function Times123(w : word): word;
+
+implementation
+
+function Times123(w : word): word;
+begin
+  Result := w*123;
+end;
+
+end.

tests/tppu/twounits/tppu_twounits_bird.pas

@@ -0,0 +1,16 @@
+unit tppu_twounits_bird;
+
+{$mode objfpc}
+
+interface
+
+procedure Walk;
+
+implementation
+
+procedure Walk;
+begin
+  writeln('Walk');
+end;
+
+end.