freepascal.compiler/compiler/utils/fpc.pp

{
    Copyright (c) 2000-2002 by Florian Klaempfl

    This file is the "loader" for the Free Pascal compiler

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************}
program fpc;

{$mode objfpc}{$H+}

uses
  SysUtils;

const
{$ifdef UNIX}
    exeext='';
{$else UNIX}
  {$ifdef HASAMIGA}
    exeext='';
  {$else}
    {$ifdef NETWARE}
      exeext='.nlm';
    {$else}
      {$ifdef ATARI}
        exeext='.ttp';
      {$else}
        exeext = '.exe';
      {$endif ATARI}
    {$endif NETWARE}
  {$endif HASAMIGA}
{$endif UNIX}

const
{$ifdef darwin}
  { the mach-o format supports "fat" binaries whereby }
  { a single executable contains machine code for     }
  { several architectures -> it is counter-intuitive  }
  { and non-standard to use different binary names    }
  { for cross-compilers vs. native compilers          }
  CrossSuffix = '';
{$else not darwin}
  CrossSuffix = 'ross';

{$endif not darwin}


procedure error(const s: string);

begin
  writeln('Error: ', s);
  halt(1);
end;

function processortosuffix(processorstr: string) : string;

begin
  case processorstr of
    'aarch64': Result := 'a64';
    'arm': Result := 'arm';
    'avr': Result := 'avr';
    'i386': Result := '386';
    'i8086': Result := '8086';
    'jvm': Result := 'jvm';
    'm68k': Result := '68k';
    'mips': Result := 'mips';
    'mipsel': Result := 'mipsel';
    'powerpc': Result := 'ppc';
    'powerpc64': Result := 'ppc64';
    'riscv32': Result := 'rv32';
    'riscv64': Result := 'rv64';
    'sparc': Result := 'sparc';
    'sparc64': Result := 'sparc64';
    'x86_64': Result := 'x64';
    'xtensa': Result := 'xtensa';
    'z80': Result := 'z80';
    'wasm32': Result := 'wasm32'
    else
      error('Illegal processor type "'+processorstr+'"');
  end;
end;

procedure InitPlatform(out ppcbin, processorname: string);

begin
  {$ifdef i386}
       ppcbin:='ppc386';
       processorname:='i386';
  {$endif i386}
  {$ifdef m68k}
       ppcbin:='ppc68k';
       processorname:='m68k';
  {$endif m68k}
  {$ifdef powerpc}
       ppcbin:='ppcppc';
       processorname:='powerpc';
  {$endif powerpc}
  {$ifdef powerpc64}
       ppcbin:='ppcppc64';
       processorname:='powerpc64';
  {$endif powerpc64}
  {$ifdef arm}
       ppcbin:='ppcarm';
       processorname:='arm';
  {$endif arm}
  {$ifdef aarch64}
       ppcbin:='ppca64';
       processorname:='aarch64';
  {$endif aarch64}
  {$ifdef sparc}
       ppcbin:='ppcsparc';
       processorname:='sparc';
  {$endif sparc}
  {$ifdef sparc64}
       ppcbin:='ppcsparc64';
       processorname:='sparc64';
  {$endif sparc64}
  {$ifdef x86_64}
       ppcbin:='ppcx64';
       processorname:='x86_64';
  {$endif x86_64}
  {$ifdef mipsel}
       ppcbin:='ppcmipsel';
       processorname:='mipsel';
  {$else : not mipsel}
    {$ifdef mips}
       ppcbin:='ppcmips';
       processorname:='mips';
    {$endif mips}
  {$endif not mipsel}
  {$ifdef riscv32}
       ppcbin:='ppcrv32';
       processorname:='riscv32';
  {$endif riscv32}
  {$ifdef riscv64}
       ppcbin:='ppcrv64';
       processorname:='riscv64';
  {$endif riscv64}
  {$ifdef xtensa}
       ppcbin:='ppcxtensa';
       processorname:='xtensa';
  {$endif xtensa}
  {$ifdef wasm32}
       ppcbin:='ppcwasm32';
       processorname:='wasm32';
  {$endif wasm32}
end;

function SplitPath(const HStr: string) : string;
var
  i: longint;
begin
  i := Length(Hstr);
  while (i>0) and not(Hstr[i] in ['\', '/']) do
    Dec(i);
  SplitPath := Copy(Hstr, 1, i);
end;


function FileExists(const F: string) : boolean;
var
  Info: TSearchRec;
begin
  FileExists := findfirst(F, fareadonly+faarchive+fahidden, info) = 0;
  findclose(Info);
end;

var
  warn : Boolean;
  ShowErrno : Boolean;
  extrapath: ansistring;

function findexe(var ppcbin: string) : boolean;
var
  path: string;
begin
  { add .exe extension }
  findexe := False;
  ppcbin := ppcbin+exeext;

  if (extrapath<>'') and (extrapath[length(extrapath)]<>DirectorySeparator) then
    extrapath := extrapath+DirectorySeparator;
  { get path of fpc.exe }
  path := splitpath(ParamStr(0));
    { don't try with an empty extra patch, this might have strange results
      if the current directory contains a compiler
    }
  if (extrapath<>'') and FileExists(extrapath+ppcbin) then
  begin
    ppcbin := extrapath+ppcbin;
    findexe := True;
  end
  else if (path<>'') and FileExists(path+ppcbin) then
  begin
    ppcbin := path+ppcbin;
    findexe := True;
  end
  else
  begin
    path := ExeSearch(ppcbin, getenvironmentvariable('PATH'));
    if path<>'' then
    begin
      ppcbin := path;
      findexe := True;
    end;
  end;
end;

function findcompiler(basecompiler, cpusuffix, exesuffix: string) : string;

begin
  Result := basecompiler;
  if exesuffix<>'' then
    Result := Result+'-'+exesuffix;
  if not findexe(Result) then
  begin
    if cpusuffix<>'' then
    begin
      Result := 'ppc'+cpusuffix;
      if exesuffix<>'' then
        Result := Result+'-'+exesuffix;
      if not findexe(Result) then
        Result := '';
    end;
  end;
end;

<<<<<<< HEAD
procedure CheckSpecialProcessors(processorstr, processorname, ppcbin, cpusuffix, exesuffix: string);

begin
    { -PB is a special code that will show the
      default compiler and exit immediately. It's
      main usage is for Makefile }
  if processorstr = 'B' then
  begin
    { report the full name of the ppcbin }
    writeln(findcompiler(ppcbin, cpusuffix, exesuffix));
    halt(0);
  end;
    { -PP is a special code that will show the
       processor and exit immediately. It's
       main usage is for Makefile }
  if processorstr = 'P' then
  begin
    { report the processor }
    writeln(processorname);
    halt(0);
  end;
end;

Function FindConfigFile(const aFile : string) : String;
// Adapted from check_configfile(fn:string; var foundfn:string):boolean;
{
  Order to read configuration file :
  Unix:
   1 - current dir
   2 - ~/.fpc.cfg
   3 - configpath
   4 - /etc
  Windows:
   1 - current dir
   2 - home dir of user or all users
   3 - config path
   4 - next to binary
  Other:
   1 - current dir
   3 - config path
   4 - next to binary
}

var
  {$ifdef unix}hs,{$endif} aSearchPath,exepath,configpath : string;

  Procedure AddToPath(aDir : String);
=======
    procedure CheckSpecialProcessors(processorstr,processorname,ppcbin,cpusuffix,exesuffix : string);

    begin
      { -PB is a special code that will show the
        default compiler and exit immediately. It's
        main usage is for Makefile }
      if processorstr='B' then
        begin
          { report the full name of the ppcbin }
          writeln(findcompiler(ppcbin,cpusuffix,exesuffix));
          halt(0);
        end;
      { -PP is a special code that will show the
         processor and exit immediately. It's
         main usage is for Makefile }
      if processorstr='P' then
        begin
          { report the processor }
          writeln(processorname);
          halt(0);
        end;
   end;


  var
     s              : ansistring;
     cpusuffix,
     exesuffix,
     processorname,
     ppcbin,
     targetname,
     processorstr   : string;
     ppccommandline : array of ansistring;
     ppccommandlinelen : longint;
     i : longint;
     errorvalue     : Longint;
>>>>>>> 319f7e796d (* Refactor check for -PB and -PP for clarity of flow)

  begin
    if aDir='' then exit;
    if (aSearchPath<>'') then
      aSearchPath:=aSearchPath+PathSeparator;
    aSearchPath:=aSearchPath+IncludeTrailingPathDelimiter(SetDirSeparators(aDir));
  end;

begin
  if FileExists(aFile) then
    Exit(aFile);
  ExePath:=SetDirSeparators(ExtractFilePath(paramstr(0)));
  aSearchPath:='';
  { retrieve configpath }
  configpath:=SetDirSeparators(GetEnvironmentVariable('PPC_CONFIG_PATH'));
{$ifdef Unix}
  hs:=SetDirSeparators(GetEnvironmentVariable('HOME'));
  if (hs<>'') then
    begin
    Result:=IncludeTrailingPathDelimiter(hs)+'.'+aFile;
    if FileExists(Result) then
      exit;
    end;
  if configpath='' then
    configpath:=ExpandFileName(ExePath+'../etc/');
{$endif}
  AddToPath(ConfigPath);
{$ifdef WINDOWS}
  AddToPath(GetEnvironmentVariable('USERPROFILE'));
  AddToPath(GetEnvironmentVariable('ALLUSERSPROFILE'));
{$endif WINDOWS}
{$ifdef Unix}
  AddToPath('/etc/');
{$else}
  AddToPath(exepath);
{$endif}
  Result:=FileSearch(aFile,aSearchPath);
end;

Procedure CheckWarn(aOpt : String);

Var
  Len,I : integer;

begin
  Len:=Length(aOpt);
  For I:=1 to Len do
    begin
    if (aOpt[i]='w') then
      Warn:=(I=Len) or (aOpt[i+1]<>'-');
    if (aOpt[i]='q') then
      ShowErrNo:=(I=Len) or (aOpt[i+1]<>'-');
    end;
end;

procedure SetExeSuffix(var ExeSuffix : string; aValue : string);

begin
  if ExeSuffix='' then
    exesuffix :=aValue
  else if Warn then
    begin
    Write('Warning: ');
    if ShowErrNo then
      Write('(99999) ');
    Writeln('Compiler version already set to: ',ExeSuffix);
    end;
end;

Procedure ProcessConfigFile(aFileName : String; var ExeSuffix : String);

  Function Stripline(aLine : String) : string;

  Var
    P : integer;

  begin
    if (aLine<>'') and (aLine[1]=';') then exit;
    Pos('#',aLine); // no ifdef or include.
    if P=0 then
      P:=Length(aLine)+1;
    Result:=Copy(aLine,1,P-1);
  end;

Var
  aFile : Text;
  aLine : String;

begin
  Assign(aFile,aFileName);
  {$push}{$I-}
  filemode:=0;
  Reset(aFile);
  {$pop}
  if ioresult<>0 then
    Error('Cannot open config file: '+aFileName);
  While not EOF(aFile) do
    begin
    ReadLn(aFile,aLine);
    aLine:=StripLine(aLine);
    if aLine='' then
      continue;
    if Copy(aLine,1,2)='-V' then
      SetExeSuffix(ExeSuffix,Copy(aLine,3,Length(aLine)-2));
    end;
  {$i+}
  Close(aFile);
end;


var
  s,CfgFile: ansistring;
  CPUSuffix, ExeSuffix, SourceCPU, ppcbin, TargetName, TargetCPU: string;
  PPCCommandLine: array of ansistring;
  PPCCommandLineLen: longint;
  i: longint;
  ErrorValue: longint;

  procedure AddToCommandLine(S: string);

  begin
    PPCCommandLine[PPCCommandLineLen] := S;
    Inc(PPCCommandLineLen);
  end;

begin
  ppccommandline := [];
  setlength(ppccommandline, paramcount);
  ppccommandlinelen := 0;
  cpusuffix := '';        // if not empty, signals attempt at cross
  // compiler.
  extrapath := '';
  initplatform(ppcbin, SourceCPU);
  exesuffix := '';                      { Default is just the name }
  if ParamCount = 0 then
  begin
    SetLength(PPCCommandLine, 1);
    AddToCommandLine('-?F'+ParamStr(0));
  end
  else
    for i := 1 to paramcount do
    begin
      s := ParamStr(i);
      if pos('-t', s) = 1 then
      begin
        targetname := copy(s, 3, length(s)-2);
        AddToCommandLine(S);
      end
      else if pos('-V', s) = 1 then
        SetExeSuffix(ExeSuffix,copy(s, 3, length(s)-2))
      else
      begin
        if pos('-P', s) = 1 then
        begin
          TargetCPU := copy(s, 3, length(s)-2);
          CheckSpecialProcessors(TargetCPU, SourceCPU, ppcbin, cpusuffix, exesuffix);
          if TargetCPU<>SourceCPU then
          begin
            cpusuffix := processortosuffix(TargetCPU);
            ppcbin := 'ppc'+crosssuffix+cpusuffix;
          end;
        end
        else if pos('-Xp', s) = 1 then
          extrapath := copy(s, 4, length(s)-3)
        else
        begin
          if pos('-h', s) = 1 then
            AddToCommandLine('-hF'+ParamStr(0))
          else if pos('-?', s) = 1 then
            AddToCommandLine('-?F'+ParamStr(0))
          else
            begin
            AddToCommandLine(S);
            if pos('-v', s) = 1 then
              CheckWarn(Copy(S,3,length(S)-2));
            end;
        end;
      end;
    end;
  if (TargetName<>'') then
    begin
    S:='fpc-'+TargetName+'.cfg';
    CfgFile:=FindConfigFile(s);
    if CfgFile='' then
      Error('Cannot find subtarget config file: '+s);
    ProcessConfigFile(CfgFile,ExeSuffix);
    end;
  SetLength(ppccommandline, ppccommandlinelen);
  ppcbin := findcompiler(ppcbin, cpusuffix, exesuffix);

  { call ppcXXX }
  try
    errorvalue := ExecuteProcess(ppcbin, ppccommandline);
  except
    on e: Exception do
      error(ppcbin+' can''t be executed, error message: '+e.message);
  end;
  if (errorvalue<>0) and
    (paramcount<>0) then
    error(ppcbin+' returned an error exitcode');
  halt(errorvalue);
end.