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
  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;

  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, 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
        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
            AddToCommandLine(S);
        end;
      end;
    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.