Merge branch source:main into main

compiler/fmodule.pas

@@ -192,7 +192,7 @@ interface
         mainname      : pshortstring; { alternate name for "main" procedure }
         package       : tpackage;
 
-        used_units           : tlinkedlist;
+        used_units           : tlinkedlist; { list of tused_unit }
         dependent_units      : tlinkedlist;
 
         localunitsearchpath,           { local searchpaths }
@@ -905,7 +905,7 @@ implementation
           Because the used_units is used in loops in the load cycle(s) which
           can recurse into the same unit due to circular dependencies,
           we do not destroy the list, we only update the contents.
-          As a result so the loop variable does not get reset during the loop.
+          As a result the loop variable does not get reset during the loop.
           For recompile, we recreate the list }
         if for_recompile then
           begin

installer/install.dat

@@ -1,6 +1,4 @@
 #
-# $Id: install.dat,v 1.39 2005/03/06 18:00:07 hajny Exp $
-#
 # Install file for Go32v2/Win32/OS2/EMX
 #
 # Warning: no package should contain more than 31 files (32-bit version

tests/tppu/.gitignore

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

tests/tppu/bug41291/bug41291_app.pas

@@ -0,0 +1,7 @@
+program bug41291_app;
+
+uses
+  bug41291_mseclasses;
+
+begin
+end.

tests/tppu/bug41291/bug41291_mclasses.pas

@@ -0,0 +1,13 @@
+unit bug41291_mclasses;
+
+interface
+
+type
+  TMyType = integer;
+
+implementation
+
+uses
+  bug41291_mseclasses;
+
+end.

tests/tppu/bug41291/bug41291_mseapplication.pas

@@ -0,0 +1,9 @@
+unit bug41291_mseapplication;
+
+interface
+
+uses bug41291_mseclasses;
+
+implementation
+
+end.

tests/tppu/bug41291/bug41291_mseclasses.pas

@@ -0,0 +1,21 @@
+unit bug41291_mseclasses;
+
+interface
+
+uses
+  bug41291_mclasses,
+  bug41291_mseifiglob;
+
+procedure alive(acomponent: TMyType);
+
+implementation
+
+uses
+  bug41291_mseapplication;
+
+procedure alive(acomponent: TMyType); inline;
+begin
+end;
+
+
+end.

tests/tppu/bug41291/bug41291_mseeditglob.pas

@@ -0,0 +1,9 @@
+unit bug41291_mseeditglob;
+
+interface
+
+implementation
+
+uses bug41291_mseclasses;
+
+end.

tests/tppu/bug41291/bug41291_mseifiglob.pas

@@ -0,0 +1,9 @@
+unit bug41291_mseifiglob;
+
+interface
+
+uses bug41291_mseeditglob;
+
+implementation
+
+end.

tests/tppu/bug41291/ppus/.gitignore

@@ -0,0 +1 @@
+bug41291_app

tests/tppu/changeinner1/changeinner1_bird.pas

@@ -0,0 +1,16 @@
+unit changeinner1_bird;
+
+{$mode objfpc}
+
+interface
+
+function Fly(w : word): word;
+
+implementation
+
+function Fly(w : word): word;
+begin
+  Result := 5*w; // changed
+end;
+
+end.

tests/tppu/changeinner1/changeinner1_prg.pas

@@ -0,0 +1,7 @@
+{$mode objfpc}
+
+uses changeinner1_ant;
+
+begin
+  writeln(Crawl(2));
+end.

tests/tppu/changeinner1/ppus/.gitignore

@@ -0,0 +1 @@
+changeinner1_prg

tests/tppu/changeinner1/src1/changeinner1_ant.pas

@@ -0,0 +1,18 @@
+unit changeinner1_ant;
+
+{$mode objfpc}
+
+interface
+
+uses changeinner1_bird;
+
+function Crawl(w : word): word;
+
+implementation
+
+function Crawl(w : word): word;
+begin
+  Result := Fly(w*2);
+end;
+
+end.

tests/tppu/changeinner1/src2/changeinner1_ant.pas

@@ -0,0 +1,18 @@
+unit changeinner1_ant;
+
+{$mode objfpc}
+
+interface
+
+uses changeinner1_bird;
+
+function Crawl(w : word): word;
+
+implementation
+
+function Crawl(w : word): word;
+begin
+  Result := 7 * Fly(w); // changed
+end;
+
+end.

tests/tppu/changeleaf1/changeleaf1_ant.pas

@@ -0,0 +1,18 @@
+unit changeleaf1_ant;
+
+{$mode objfpc}
+
+interface
+
+uses changeleaf1_bird;
+
+function Crawl(w : word): word;
+
+implementation
+
+function Crawl(w : word): word;
+begin
+  Result := Fly(w*2);
+end;
+
+end.

tests/tppu/changeleaf1/changeleaf1_prg.pas

@@ -0,0 +1,7 @@
+{$mode objfpc}
+
+uses changeleaf1_ant;
+
+begin
+  writeln(Crawl(2));
+end.

tests/tppu/changeleaf1/ppus/.gitignore

@@ -0,0 +1 @@
+changeleaf1_prg

tests/tppu/changeleaf1/src1/changeleaf1_bird.pas

@@ -0,0 +1,16 @@
+unit changeleaf1_bird;
+
+{$mode objfpc}
+
+interface
+
+function Fly(w : word): word;
+
+implementation
+
+function Fly(w : word): word;
+begin
+  Result:=w*7;
+end;
+
+end.

tests/tppu/changeleaf1/src2/changeleaf1_bird.pas

@@ -0,0 +1,16 @@
+unit changeleaf1_bird;
+
+{$mode objfpc}
+
+interface
+
+function Fly(w : word): word;
+
+implementation
+
+function Fly(w : word): word;
+begin
+  Result := 5*w; // changed
+end;
+
+end.

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; inline;
+begin
+  writeln(Times123(2));
+end;
+
+end.

tests/tppu/implinline2/implinline2_ant.pas

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

tests/tppu/implinline2/implinline2_bird.pas

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

tests/tppu/implinline2/implinline2_prg.pas

@@ -0,0 +1,7 @@
+{$mode objfpc}
+
+uses implinline2_ant;
+
+begin
+  writeln(times123(2));
+end.

tests/tppu/implinline2/ppus/.gitignore

@@ -0,0 +1 @@
+implinline2_prg

tests/tppu/implinline3/implinline3_prg.pas

@@ -0,0 +1,7 @@
+{$mode objfpc}
+
+uses implinline3_ant;
+
+begin
+  writeln(times123(2));
+end.

tests/tppu/implinline3/ppus/.gitignore

@@ -0,0 +1 @@
+implinline3_prg

tests/tppu/implinline3/src1/implinline3_ant.pas

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

tests/tppu/implinline3/src1/implinline3_bird.pas

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

tests/tppu/implinline3/src2/implinline3_ant.pas

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

tests/tppu/implinline3/src2/implinline3_bird.pas

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

tests/tppu/readme.txt

@@ -0,0 +1,13 @@
+Test suite for running the compiler, building ppus, running again, checking what ppus were build.
+
+How to use:
+- Compile the compiler, for example via ../../compiler/ppcx64.lpi, creating ../../compiler/x86_64/pp
+- Compile this testsuite testppu.lpi
+- Run this testsuite:
+  Set environment variable PP to the compiler and run all tests:
+    PP=../../compiler/x86_64/pp ./testppu  
+
+Or run a single test:
+
+PP=../../compiler/x86_64/pp ./testppu --suite=TestImplInline1
+

tests/tppu/tcrecompile.pas

@@ -0,0 +1,345 @@
+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; // 2 units
+    procedure TestChangeLeaf1; // prog+2 units, change leaf
+    procedure TestChangeInner1; // prog+2 units, change inner unit, keep leaf
+
+    // inline modifier in implementation (not in interface)
+    procedure TestImplInline1; // 2 units, cycle, impl inline
+    procedure TestImplInline2; // program + 2 units cycle, impl inline
+    procedure TestImplInline_Bug41291; // program plus 3 cycles
+    procedure TestImplInline3; // program + 2 units cycle, impl inline, implementation changed
+  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;
+begin
+  PP:=GetEnvironmentVariable(String('PP'));
+  if PP>'' then
+  begin
+    CheckCompiler;
+    exit;
+  end;
+
+  raise Exception.Create('I need environment var "PP"');
+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;
+  // the bird ppu does not depend on ant, so it is kept
+  CheckCompiled(['tppu_twounits_ant.pas']);
+end;
+
+procedure TTestRecompile.TestChangeLeaf1;
+begin
+  UnitPath:='changeleaf1;changeleaf1'+PathDelim+'src1';
+  OutDir:='changeleaf1'+PathDelim+'ppus';
+  MainSrc:='changeleaf1'+PathDelim+'changeleaf1_prg.pas';
+
+  Step:='First compile';
+  CleanOutputDir;
+  Compile;
+  CheckCompiled(['changeleaf1_prg.pas','changeleaf1_ant.pas','changeleaf1_bird.pas']);
+
+  Step:='Second compile';
+  UnitPath:='changeleaf1;changeleaf1'+PathDelim+'src2';
+  Compile;
+  // the main src is always compiled, bird changed, so all ant must be recompiled as well
+  CheckCompiled(['changeleaf1_prg.pas','changeleaf1_ant.pas','changeleaf1_bird.pas']);
+end;
+
+procedure TTestRecompile.TestChangeInner1;
+begin
+  UnitPath:='changeinner1;changeinner1'+PathDelim+'src1';
+  OutDir:='changeinner1'+PathDelim+'ppus';
+  MainSrc:='changeinner1'+PathDelim+'changeinner1_prg.pas';
+
+  Step:='First compile';
+  CleanOutputDir;
+  Compile;
+  CheckCompiled(['changeinner1_prg.pas','changeinner1_ant.pas','changeinner1_bird.pas']);
+
+  Step:='Second compile';
+  UnitPath:='changeinner1;changeinner1'+PathDelim+'src2';
+  Compile;
+  // the main src is always compiled, ant changed, bird is kept
+  CheckCompiled(['changeinner1_prg.pas','changeinner1_ant.pas']);
+end;
+
+procedure TTestRecompile.TestImplInline1;
+// unit ant uses bird
+// unit bird impl uses ant and has a function with inline modifier in implementation
+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;
+  // the main src is always compiled, and since bird ppu depends on ant, it is always compiled as well
+  CheckCompiled(['implinline1_ant.pas','implinline1_bird.pas']);
+end;
+
+procedure TTestRecompile.TestImplInline2;
+// prg uses ant
+// unit ant uses bird
+// unit bird impl uses ant and has a function with inline modifier in implementation
+begin
+  UnitPath:='implinline2';
+  OutDir:='implinline2'+PathDelim+'ppus';
+  MainSrc:='implinline2'+PathDelim+'implinline2_prg.pas';
+
+  Step:='First compile';
+  CleanOutputDir;
+  Compile;
+  CheckCompiled(['implinline2_prg.pas','implinline2_ant.pas','implinline2_bird.pas']);
+
+  Step:='Second compile';
+  Compile;
+  // the main src is always compiled, the two ppus of ant and bird are kept
+  CheckCompiled(['implinline2_prg.pas']);
+end;
+
+procedure TTestRecompile.TestImplInline_Bug41291;
+begin
+  UnitPath:='bug41291';
+  OutDir:='bug41291'+PathDelim+'ppus';
+  MainSrc:='bug41291'+PathDelim+'bug41291_app.pas';
+
+  Step:='First compile';
+  CleanOutputDir;
+  Compile;
+  CheckCompiled(['bug41291_app.pas','bug41291_mclasses.pas','bug41291_mseapplication.pas',
+    'bug41291_mseclasses.pas','bug41291_mseeditglob.pas','bug41291_mseifiglob.pas']);
+
+  Step:='Second compile';
+  Compile;
+  // the main src is always compiled, the other ppus are kept
+  CheckCompiled(['bug41291_app.pas']);
+end;
+
+procedure TTestRecompile.TestImplInline3;
+begin
+  UnitPath:='implinline3;implinline3'+PathDelim+'src1';
+  OutDir:='implinline3'+PathDelim+'ppus';
+  MainSrc:='implinline3'+PathDelim+'implinline3_prg.pas';
+
+  Step:='First compile';
+  CleanOutputDir;
+  Compile;
+  CheckCompiled(['implinline3_prg.pas','implinline3_ant.pas','implinline3_bird.pas']);
+
+  Step:='Second compile';
+  UnitPath:='implinline3;implinline3'+PathDelim+'src2';
+  Compile;
+  // the main src is always compiled, and the ant impl changed, so bird is also compiled
+  CheckCompiled(['implinline3_prg.pas','implinline3_ant.pas','implinline3_bird.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.