freepascal.compiler/compiler/globals.pas

{
    Copyright (c) 1998-2002 by Florian Klaempfl

    This unit implements some support functions and global variables

    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.

 ****************************************************************************
}
unit globals;

{$i fpcdefs.inc}

{ Use the internal linker by default }
{ define INTERNALLINKER}

interface

    uses
{$ifdef win32}
      windows,
{$endif}
{$ifdef hasunix}
  {$ifdef havelinuxrtl10}
      linux,
  {$else}
      Baseunix,unix,
  {$endif}
{$endif}
{$IFDEF USE_SYSUTILS}
      SysUtils,
{$ELSE USE_SYSUTILS}
      strings,
      dos,
{$ENDIF USE_SYSUTILS}
      cutils,cclasses,
      cpuinfo,
      globtype,version,systems;

    const
       delphimodeswitches : tmodeswitches=
         [m_delphi,m_all,m_class,m_objpas,m_result,m_string_pchar,
          m_pointer_2_procedure,m_autoderef,m_tp_procvar,m_initfinal,m_default_ansistring,
          m_out,m_default_para,m_duplicate_names,m_hintdirective,m_add_pointer];
       fpcmodeswitches    : tmodeswitches=
         [m_fpc,m_all,m_string_pchar,m_nested_comment,m_repeat_forward,
          m_cvar_support,m_initfinal,m_add_pointer,m_hintdirective];
       objfpcmodeswitches : tmodeswitches=
         [m_objfpc,m_fpc,m_all,m_class,m_objpas,m_result,m_string_pchar,m_nested_comment,
          m_repeat_forward,m_cvar_support,m_initfinal,m_add_pointer,m_out,m_default_para,m_hintdirective];
       tpmodeswitches     : tmodeswitches=
         [m_tp7,m_all,m_tp_procvar,m_duplicate_names];
       gpcmodeswitches    : tmodeswitches=
         [m_gpc,m_all,m_tp_procvar];
       macmodeswitches : tmodeswitches=
         [m_mac,m_all,m_result,m_cvar_support,m_mac_procvar];


       { maximum nesting of routines }
       maxnesting = 32;

       { Filenames and extensions }
       sourceext  = '.pp';
       pasext     = '.pas';
       pext       = '.p';

       treelogfilename = 'tree.log';

{$if defined(CPUARM) and defined(FPUFPA)}
       MathQNaN : tdoublearray = (0,0,252,255,0,0,0,0);
       MathInf : tdoublearray = (0,0,240,127,0,0,0,0);
       MathNegInf : tdoublearray = (0,0,240,255,0,0,0,0);
       MathPi : tdoublearray =  (251,33,9,64,24,45,68,84);
{$else}
{$ifdef FPC_LITTLE_ENDIAN}
       MathQNaN : tdoublearray = (0,0,0,0,0,0,252,255);
       MathInf : tdoublearray = (0,0,0,0,0,0,240,127);
       MathNegInf : tdoublearray = (0,0,0,0,0,0,240,255);
       MathPi : tdoublearray =  (24,45,68,84,251,33,9,64);
       MathPiExtended : textendedarray = (53,194,104,33,162,218,15,201,0,64);
{$else FPC_LITTLE_ENDIAN}
       MathQNaN : tdoublearray = (255,252,0,0,0,0,0,0);
       MathInf : tdoublearray = (127,240,0,0,0,0,0,0);
       MathNegInf : tdoublearray = (255,240,0,0,0,0,0,0);
       MathPi : tdoublearray =  (64,9,33,251,84,68,45,24);
       MathPiExtended : textendedarray = (64,0,201,15,218,162,33,104,194,53);
{$endif FPC_LITTLE_ENDIAN}
{$endif}

    type
       TFPUException = (exInvalidOp, exDenormalized, exZeroDivide,
                        exOverflow, exUnderflow, exPrecision);
       TFPUExceptionMask = set of TFPUException;

       pfileposinfo = ^tfileposinfo;
       tfileposinfo = record
         line      : longint;
         column    : word;
         fileindex : word;
         { moduleindex : word; }
       end;

       TSearchPathList = class(TStringList)
         procedure AddPath(s:string;addfirst:boolean);overload;
         procedure AddPath(SrcPath,s:string;addfirst:boolean);overload;
         procedure AddList(list:TSearchPathList;addfirst:boolean);
         function  FindFile(const f : string;var foundfile:string):boolean;
       end;

       tcodepagestring = string[20];

    var
       { specified inputfile }
       inputdir          : dirstr;
       inputfile         : namestr;
       inputextension    : extstr;
       { specified outputfile with -o parameter }
       outputfile        : namestr;
       outputprefix      : pstring;
       outputsuffix      : pstring;
       outputextension   : namestr;
       { specified with -FE or -FU }
       outputexedir      : dirstr;
       outputunitdir     : dirstr;

       { things specified with parameters }
       paratarget        : tsystem;
       paratargetdbg     : tdbg;
       paratargetasm     : tasm;
       paralinkoptions,
       paradynamiclinker : string;
       paraprintnodetree : byte;
       parapreprocess    : boolean;
       printnodefile     : text;

       {  typical cross compiling params}

       { directory where the utils can be found (options -FD) }
       utilsdirectory : dirstr;
       { targetname specific prefix used by these utils (options -XP<path>) }
       utilsprefix    : dirstr;
       cshared        : boolean;        { pass --shared to ld to link C libs shared}
       Dontlinkstdlibpath: Boolean;     { Don't add std paths to linkpath}
       rlinkpath      : dirstr;         { rpath-link linkdir override}

       { some flags for global compiler switches }
       do_build,
       do_release,
       do_make       : boolean;
       { path for searching units, different paths can be seperated by ; }
       exepath            : dirstr;  { Path to ppc }
       librarysearchpath,
       unitsearchpath,
       objectsearchpath,
       includesearchpath  : TSearchPathList;
       autoloadunits      : string;

       { linking }
       usewindowapi  : boolean;
       description   : string;
       DescriptionSetExplicity : boolean;
       dllversion    : string;
       dllmajor,
       dllminor,
       dllrevision   : word;  { revision only for netware }
       UseDeffileForExports    : boolean;
       UseDeffileForExportsSetExplicitly : boolean;
       RelocSection : boolean;
       RelocSectionSetExplicitly : boolean;
       LinkTypeSetExplicitly : boolean;

       akttokenpos,                  { position of the last token }
       aktfilepos : tfileposinfo;    { current position }

       nwscreenname : string;
       nwthreadname : string;
       nwcopyright  : string;

       codegenerror : boolean;           { true if there is an error reported }

       block_type : tblock_type;         { type of currently parsed block }

       parsing_para_level : integer;     { parameter level, used to convert
                                           proc calls to proc loads in firstcalln }
       compile_level : word;
       make_ref : boolean;
       resolving_forward : boolean;      { used to add forward reference as second ref }
       inlining_procedure : boolean;     { are we inlining a procedure }
       exceptblockcounter    : integer;  { each except block gets a unique number check gotos      }
       aktexceptblock        : integer;  { the exceptblock number of the current block (0 if none) }

     { commandline values }
       initglobalswitches : tglobalswitches;
       initmoduleswitches : tmoduleswitches;
       initlocalswitches  : tlocalswitches;
       initmodeswitches   : tmodeswitches;
       {$IFDEF testvarsets}
        Initsetalloc,                            {0=fixed, 1 =var}
       {$ENDIF}
       initpackenum       : shortint;
     {$ifdef ansistring_bits}
       initansistring_bits: Tstringbits;
     {$endif}
       initalignment      : talignmentinfo;
       initoptprocessor,
       initspecificoptprocessor : tprocessors;
       initfputype        : tfputype;
       initasmmode        : tasmmode;
       initinterfacetype  : tinterfacetypes;
       initdefproccall    : tproccalloption;
       initsourcecodepage : tcodepagestring;

     { current state values }
       aktglobalswitches  : tglobalswitches;
       aktmoduleswitches  : tmoduleswitches;
       aktlocalswitches   : tlocalswitches;
       nextaktlocalswitches : tlocalswitches;
       localswitcheschanged : boolean;
       aktmodeswitches    : tmodeswitches;
       {$IFDEF testvarsets}
        aktsetalloc,
       {$ENDIF}
       aktpackrecords,
       aktpackenum        : shortint;
     {$ifdef ansistring_bits}
       aktansistring_bits : Tstringbits;
     {$endif}
       aktmaxfpuregisters : longint;
       aktalignment       : talignmentinfo;
       aktoptprocessor,
       aktspecificoptprocessor : tprocessors;
       aktfputype        : tfputype;
       aktasmmode         : tasmmode;
       aktinterfacetype   : tinterfacetypes;
       aktdefproccall     : tproccalloption;
       aktsourcecodepage : tcodepagestring;

     { Memory sizes }
       heapsize,
       stacksize,
       jmp_buf_size : longint;

{$Ifdef EXTDEBUG}
     { parameter switches }
       debugstop : boolean;
{$EndIf EXTDEBUG}
       { windows / OS/2 application type }
       apptype : tapptype;

    const
       DLLsource : boolean = false;
       DLLImageBase : pstring = nil;

       { used to set all registers used for each global function
         this should dramatically decrease the number of
         recompilations needed PM }
       simplify_ppu : boolean = true;

       { should we allow non static members ? }
       allow_only_static : boolean = false;

       Inside_asm_statement : boolean = false;

       global_unit_count : word = 0;

       { for error info in pp.pas }
       parser_current_file : string = '';

{$ifdef m68k}
       { PalmOS resources }
       palmos_applicationname : string = 'FPC Application';
       palmos_applicationid : string[4] = 'FPCA';
{$endif m68k}

{$ifdef powerpc}
       { default calling convention used on MorphOS }
       syscall_convention : string = 'LEGACY';
{$endif powerpc}

       { default name of the C-style "main" procedure of the library/program }
       { (this will be prefixed with the target_info.cprefix)                }
       mainaliasname : string = 'main';

    procedure abstract;

    function bstoslash(const s : string) : string;

    function getdatestr:string;
    function gettimestr:string;
    function filetimestring( t : longint) : string;

    procedure DefaultReplacements(var s:string);
    {Gives the absolute path to the current directory}
    function  GetCurrentDir:string;
    {Gives the relative path to the current directory,
     with a trailing dir separator. E. g. on unix ./ }
    function CurDirRelPath(systeminfo: tsysteminfo): string;
    function  path_absolute(const s : string) : boolean;
    Function  PathExists ( F : String) : Boolean;
    Function  FileExists ( Const F : String) : Boolean;
    function  FileExistsNonCase(const path,fn:string;var foundfile:string):boolean;
    Function  RemoveFile(const f:string):boolean;
    Function  RemoveDir(d:string):boolean;
    Function  GetFileTime ( Var F : File) : Longint;
    Function  GetNamedFileTime ( Const F : String) : Longint;
    {Extracts the path without its filename, from a path.}
    Function  SplitPath(const s:string):string;
    Function  SplitFileName(const s:string):string;
    Function  SplitName(const s:string):string;
    Function  SplitExtension(Const HStr:String):String;
    Function  AddExtension(Const HStr,ext:String):String;
    Function  ForceExtension(Const HStr,ext:String):String;
    Function  FixPath(s:string;allowdot:boolean):string;
    function  FixFileName(const s:string):string;
    function  TargetFixPath(s:string;allowdot:boolean):string;
    function  TargetFixFileName(const s:string):string;
    procedure SplitBinCmd(const s:string;var bstr: String;var cstr:TCmdStr);
    function  FindFile(const f : string;path : string;var foundfile:string):boolean;
    function  FindFilePchar(const f : string;path : pchar;var foundfile:string):boolean;
    function  FindExe(const bin:string;var foundfile:string):boolean;
    function  GetShortName(const n:string):string;
    function  cleanpath(const s:string):String;

    function Shell(const command:string): longint;
    function  GetEnvPChar(const envname:string):pchar;
    procedure FreeEnvPChar(p:pchar);

    procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
    function is_number_float(d : double) : boolean;

    function SetAktProcCall(const s:string; changeInit: boolean):boolean;
    function SetProcessor(const s:string; changeInit: boolean):boolean;
    function SetFpuType(const s:string; changeInit: boolean):boolean;

    procedure InitGlobals;
    procedure DoneGlobals;

    function  string2guid(const s: string; var GUID: TGUID): boolean;
    function  guid2string(const GUID: TGUID): string;

    function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;

    {# Routine to get the required alignment for size of data, which will
       be placed in bss segment, according to the current alignment requirements }
    function var_align(siz: longint): longint;
    {# Routine to get the required alignment for size of data, which will
       be placed in data/const segment, according to the current alignment requirements }
    function const_align(siz: longint): longint;

{$IFDEF MACOS_USE_FAKE_SYSUTILS}

{Since SysUtils is not yet available for MacOS, fake
 Exceptions classes are included here.}

type
   { exceptions }
   Exception = class(TObject);

   EExternal = class(Exception);

   { integer math exceptions }
   EInterror    = Class(EExternal);
   EDivByZero   = Class(EIntError);
   ERangeError  = Class(EIntError);
   EIntOverflow = Class(EIntError);

   { General math errors }
   EMathError  = Class(EExternal);
   EInvalidOp  = Class(EMathError);
   EZeroDivide = Class(EMathError);
   EOverflow   = Class(EMathError);
   EUnderflow  = Class(EMathError);

{$ENDIF MACOS_USE_FAKE_SYSUTILS}

implementation

    uses
{$ifdef macos}
      macutils,
{$endif}
      comphook;

    procedure abstract;
      begin
        do_internalerror(255);
      end;


    procedure WarnNonExistingPath(const path : string);
      begin
        if assigned(do_comment) then
          do_comment(V_Tried,'Path "'+path+'" not found');
      end;


    function bstoslash(const s : string) : string;
    {
      return string s with all \ changed into /
    }
      var
         i : longint;
      begin
        for i:=1to length(s) do
         if s[i]='\' then
          bstoslash[i]:='/'
         else
          bstoslash[i]:=s[i];
         bstoslash[0]:=s[0];
      end;


{****************************************************************************
                               Time Handling
****************************************************************************}

    Function L0(l:longint):string;
    {
      return the string of value l, if l<10 then insert a zero, so
      the string is always at least 2 chars '01','02',etc
    }
      var
        s : string;
      begin
        Str(l,s);
        if l<10 then
         s:='0'+s;
        L0:=s;
      end;


   function gettimestr:string;
   {
     get the current time in a string HH:MM:SS
   }
      var
        hour,min,sec,hsec : word;
      begin
{$IFDEF USE_SYSUTILS}
        DecodeTime(Time,hour,min,sec,hsec);
{$ELSE USE_SYSUTILS}
        dos.gettime(hour,min,sec,hsec);
{$ENDIF USE_SYSUTILS}
        gettimestr:=L0(Hour)+':'+L0(min)+':'+L0(sec);
      end;


   function getdatestr:string;
   {
     get the current date in a string YY/MM/DD
   }
      var
{$IFDEF USE_SYSUTILS}
        Year,Month,Day: Word;
{$ELSE USE_SYSUTILS}
        Year,Month,Day,Wday : Word;
{$ENDIF USE_SYSUTILS}
      begin
{$IFDEF USE_SYSUTILS}
        DecodeDate(Date,year,month,day);
{$ELSE USE_SYSUTILS}
        dos.getdate(year,month,day,wday);
{$ENDIF USE_SYSUTILS}
        getdatestr:=L0(Year)+'/'+L0(Month)+'/'+L0(Day);
      end;


   function  filetimestring( t : longint) : string;
   {
     convert dos datetime t to a string YY/MM/DD HH:MM:SS
   }
     var
{$IFDEF USE_SYSUTILS}
       DT : TDateTime;
       hsec : word;
{$ELSE USE_SYSUTILS}
       DT : DateTime;
{$ENDIF USE_SYSUTILS}
       Year,Month,Day: Word;
       hour,min,sec : word;
     begin
       if t=-1 then
        begin
          Result := 'Not Found';
          exit;
        end;
{$IFDEF USE_SYSUTILS}
       DT := FileDateToDateTime(t);
       DecodeTime(DT,hour,min,sec,hsec);
       DecodeDate(DT,year,month,day);
{$ELSE USE_SYSUTILS}
       unpacktime(t,DT);
       year := DT.year;
       month := DT.month;
       day := DT.day;
       hour := DT.hour;
       min := DT.min;
       sec := DT.sec;
{$ENDIF USE_SYSUTILS}
       Result := L0(Year)+'/'+L0(Month)+'/'+L0(Day)+' '+L0(Hour)+':'+L0(min)+':'+L0(sec);
     end;


{****************************************************************************
                          Default Macro Handling
****************************************************************************}

     procedure DefaultReplacements(var s:string);
       begin
         { Replace some macros }
         Replace(s,'$FPCVERSION',version_string);
         Replace(s,'$FPCFULLVERSION',full_version_string);
         Replace(s,'$FPCDATE',date_string);
         Replace(s,'$FPCCPU',target_cpu_string);
         Replace(s,'$FPCOS',target_os_string);
         if tf_use_8_3 in Source_Info.Flags then
           Replace(s,'$FPCTARGET',target_os_string)
         else
           Replace(s,'$FPCTARGET',target_full_string);
       end;


{****************************************************************************
                               File Handling
****************************************************************************}

     var
       CachedCurrentDir : string;

   {Gives the absolute path to the current directory}
   function GetCurrentDir:string;
     begin
       if CachedCurrentDir='' then
         begin
           GetDir(0,CachedCurrentDir);
           CachedCurrentDir:=FixPath(CachedCurrentDir,false);
         end;
       result:=CachedCurrentDir;
     end;

   {Gives the relative path to the current directory,
    with a trailing dir separator. E. g. on unix ./ }
   function CurDirRelPath(systeminfo: tsysteminfo): string;

   begin
     if systeminfo.system <> system_powerpc_macos then
       CurDirRelPath:= '.'+systeminfo.DirSep
     else
       CurDirRelPath:= ':'
   end;


   function path_absolute(const s : string) : boolean;
   {
     is path s an absolute path?
   }
     begin
        path_absolute:=false;
{$ifdef unix}
        if (length(s)>0) and (s[1]='/') then
          path_absolute:=true;
{$else unix}
{$ifdef amiga}
        if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or (Pos(':',s) = length(s)) then
          path_absolute:=true;
{$else}
{$ifdef macos}
        if IsMacFullPath(s) then
          path_absolute:=true;
{$else}
        if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or
           ((length(s)>2) and (s[2]=':') and ((s[3]='\') or (s[3]='/'))) then
          path_absolute:=true;
{$endif macos}
{$endif amiga}
{$endif unix}
     end;

{$ifndef FPC}
    Procedure FindClose(var Info : SearchRec);
      Begin
      End;
{$endif not FPC}


    Function FileExists ( Const F : String) : Boolean;
{$IFDEF USE_SYSUTILS}
{$ELSE USE_SYSUTILS}
      var
         Info : SearchRec;
{$ENDIF USE_SYSUTILS}
      begin
{$IFDEF USE_SYSUTILS}
        Result:=SysUtils.FileExists(f);
{$ELSE USE_SYSUTILS}
        findfirst(F,readonly+archive+hidden,info);
        result:=(doserror=0);
        findclose(Info);
{$ENDIF USE_SYSUTILS}
        if assigned(do_comment) then
         begin
           if Result then
             do_comment(V_Tried,'Searching file '+F+'... found')
           else
             do_comment(V_Tried,'Searching file '+F+'... not found');
         end;
      end;


    function FileExistsNonCase(const path,fn:string;var foundfile:string):boolean;
      var
        fn2 : string;
      begin
        result:=false;
        if source_info.files_case_relevent then
          begin
            {
              Search order for case sensitive systems:
               1. NormalCase
               2. lowercase
               3. UPPERCASE
            }
            FoundFile:=path+fn;
            If FileExists(FoundFile) then
             begin
               result:=true;
               exit;
             end;
            fn2:=Lower(fn);
            if fn2<>fn then
              begin
                FoundFile:=path+fn2;
                If FileExists(FoundFile) then
                 begin
                   result:=true;
                   exit;
                 end;
              end;
            fn2:=Upper(fn);
            if fn2<>fn then
              begin
                FoundFile:=path+fn2;
                If FileExists(FoundFile) then
                 begin
                   result:=true;
                   exit;
                 end;
              end;
          end
        else
          begin
            { None case sensitive only lowercase }
            FoundFile:=path+Lower(fn);
            If FileExists(FoundFile) then
             begin
               result:=true;
               exit;
             end;
          end;
        { Set foundfile to something usefull }
        FoundFile:=fn;
      end;


    Function PathExists ( F : String) : Boolean;
      Var
{$IFDEF USE_SYSUTILS}
{$ELSE USE_SYSUTILS}
        FF : file;
{$ENDIF USE_SYSUTILS}
        A: word;
        I: longint;
      begin
        if F = '' then
          begin
            PathExists := true;
            exit;
          end;
{$ifdef USE_SYSUTILS}
        F := ExpandFileName(F);
{$else USE_SYSUTILS}
        F := FExpand (F);
{$endif USE_SYSUTILS}
        I := Pos (DriveSeparator, F);
        if (F [Length (F)] = DirectorySeparator)
                  and (((I = 0) and (Length (F) > 1)) or (I <> Length (F) - 1))
          then
            Delete (F, Length (F), 1);
{$IFDEF USE_SYSUTILS}
        PathExists := FileGetAttr(F) and faDirectory = faDirectory;
{$ELSE USE_SYSUTILS}
        Assign (FF, FExpand (F));
        GetFAttr (FF, A);
        PathExists := (DosError = 0) and (A and Directory = Directory);
{$ENDIF USE_SYSUTILS}
      end;


    Function RemoveFile(const f:string):boolean;
      var
        g : file;
      begin
        assign(g,f);
        {$I-}
         erase(g);
        {$I+}
        RemoveFile:=(ioresult=0);
      end;


    Function RemoveDir(d:string):boolean;
      begin
        if d[length(d)]=source_info.DirSep then
         Delete(d,length(d),1);
        {$I-}
         rmdir(d);
        {$I+}
        RemoveDir:=(ioresult=0);
      end;


    Function SplitPath(const s:string):string;
      var
        i : longint;
      begin
        i:=Length(s);
{$ifdef macos}
        while (i>0) and not(s[i] in [':']) do
         dec(i);
{$else macos}
        while (i>0) and not(s[i] in ['/','\']) do
         dec(i);
{$endif macos}
        SplitPath:=Copy(s,1,i);
      end;


    Function SplitFileName(const s:string):string;
{$IFDEF USE_SYSUTILS}
{$ELSE USE_SYSUTILS}
      var
        p : dirstr;
        n : namestr;
        e : extstr;
{$ENDIF USE_SYSUTILS}
      begin
{$IFDEF USE_SYSUTILS}
        SplitFileName:=ExtractFileName(s);
{$ELSE USE_SYSUTILS}
        FSplit(s,p,n,e);
        SplitFileName:=n+e;
{$ENDIF USE_SYSUTILS}
      end;


    Function SplitName(const s:string):string;
      var
        i,j : longint;
      begin
        i:=Length(s);
        j:=Length(s);
        while (i>0) and not(s[i] in ['/','\']) do
         dec(i);
        while (j>0) and (s[j]<>'.') do
         dec(j);
        if j<=i then
         j:=255;
        SplitName:=Copy(s,i+1,j-(i+1));
      end;


    Function SplitExtension(Const HStr:String):String;
      var
        j : longint;
      begin
        j:=length(Hstr);
        while (j>0) and (Hstr[j]<>'.') do
         begin
           if hstr[j]=source_info.DirSep then
            j:=0
           else
            dec(j);
         end;
        if j=0 then
         j:=254;
        SplitExtension:=Copy(Hstr,j,255);
      end;


    Function AddExtension(Const HStr,ext:String):String;
      begin
        if (Ext<>'') and (SplitExtension(HStr)='') then
         AddExtension:=Hstr+Ext
        else
         AddExtension:=Hstr;
      end;


    Function ForceExtension(Const HStr,ext:String):String;
      var
        j : longint;
      begin
        j:=length(Hstr);
        while (j>0) and (Hstr[j]<>'.') do
         dec(j);
        if j=0 then
         j:=255;
        ForceExtension:=Copy(Hstr,1,j-1)+Ext;
      end;


    Function FixPath(s:string;allowdot:boolean):string;
      var
        i : longint;
      begin
        { Fix separator }
        for i:=1 to length(s) do
         if s[i] in ['/','\'] then
          s[i]:=source_info.DirSep;
        { Fix ending / }
        if (length(s)>0) and (s[length(s)]<>source_info.DirSep) and
           (s[length(s)]<>':') then
         s:=s+source_info.DirSep;
        { Remove ./ }
        if (not allowdot) and (s='.'+source_info.DirSep) then
         s:='';
        { return }
        if source_info.files_case_relevent then
         FixPath:=s
        else
         FixPath:=Lower(s);
      end;

  {Actually the version in macutils.pp could be used,
   but that would not work for crosscompiling, so this is a slightly modified
   version of it.}
  function TranslatePathToMac (const path: string; mpw: Boolean): string;

    function GetVolumeIdentifier: string;

    begin
      GetVolumeIdentifier := '{Boot}'
      (*
      if mpw then
        GetVolumeIdentifier := '{Boot}'
      else
        GetVolumeIdentifier := macosBootVolumeName;
      *)
    end;

    var
      slashPos, oldpos, newpos, oldlen, maxpos: Longint;

  begin
    oldpos := 1;
    slashPos := Pos('/', path);
    if (slashPos <> 0) then   {its a unix path}
      begin
        if slashPos = 1 then
          begin      {its a full path}
            oldpos := 2;
            TranslatePathToMac := GetVolumeIdentifier;
          end
        else     {its a partial path}
          TranslatePathToMac := ':';
      end
    else
      begin
        slashPos := Pos('\', path);
        if (slashPos <> 0) then   {its a dos path}
          begin
            if slashPos = 1 then
              begin      {its a full path, without drive letter}
                oldpos := 2;
                TranslatePathToMac := GetVolumeIdentifier;
              end
            else if (Length(path) >= 2) and (path[2] = ':') then {its a full path, with drive letter}
              begin
                oldpos := 4;
                TranslatePathToMac := GetVolumeIdentifier;
              end
            else     {its a partial path}
              TranslatePathToMac := ':';
          end;
      end;

    if (slashPos <> 0) then   {its a unix or dos path}
      begin
        {Translate "/../" to "::" , "/./" to ":" and "/" to ":" }
        newpos := Length(TranslatePathToMac);
        oldlen := Length(path);
        SetLength(TranslatePathToMac, newpos + oldlen);  {It will be no longer than what is already}
                                                                        {prepended plus length of path.}
        maxpos := Length(TranslatePathToMac);          {Get real maxpos, can be short if String is ShortString}

        {There is never a slash in the beginning, because either it was an absolute path, and then the}
        {drive and slash was removed, or it was a relative path without a preceding slash.}
        while oldpos <= oldlen do
          begin
            {Check if special dirs, ./ or ../ }
            if path[oldPos] = '.' then
              if (oldpos + 1 <= oldlen) and (path[oldPos + 1] = '.') then
                begin
                  if (oldpos + 2 > oldlen) or (path[oldPos + 2] in ['/', '\']) then
                    begin
                      {It is "../" or ".."  translates to ":" }
                      if newPos = maxPos then
                        begin {Shouldn't actually happen, but..}
                          Exit('');
                        end;
                      newPos := newPos + 1;
                      TranslatePathToMac[newPos] := ':';
                      oldPos := oldPos + 3;
                      continue;  {Start over again}
                    end;
                end
              else if (oldpos + 1 > oldlen) or (path[oldPos + 1] in ['/', '\']) then
                begin
                  {It is "./" or "."  ignor it }
                  oldPos := oldPos + 2;
                  continue;  {Start over again}
                end;

            {Collect file or dir name}
            while (oldpos <= oldlen) and not (path[oldPos] in ['/', '\']) do
              begin
                if newPos = maxPos then
                  begin {Shouldn't actually happen, but..}
                    Exit('');
                  end;
                newPos := newPos + 1;
                TranslatePathToMac[newPos] := path[oldPos];
                oldPos := oldPos + 1;
              end;

            {When we come here there is either a slash or we are at the end.}
            if (oldpos <= oldlen) then
              begin
                if newPos = maxPos then
                  begin {Shouldn't actually happen, but..}
                    Exit('');
                  end;
                newPos := newPos + 1;
                TranslatePathToMac[newPos] := ':';
                oldPos := oldPos + 1;
              end;
          end;

        SetLength(TranslatePathToMac, newpos);
      end
    else if (path = '.') then
      TranslatePathToMac := ':'
    else if (path = '..') then
      TranslatePathToMac := '::'
    else
      TranslatePathToMac := path;  {its a mac path}
  end;


   function FixFileName(const s:string):string;
     var
       i      : longint;
     begin
       if source_info.system = system_powerpc_MACOS then
         FixFileName:= TranslatePathToMac(s, true)
       else if source_info.files_case_relevent then
        begin
          for i:=1 to length(s) do
           begin
             case s[i] of
               '/','\' :
                 FixFileName[i]:=source_info.dirsep;
               else
                 FixFileName[i]:=s[i];
             end;
           end;
          FixFileName[0]:=s[0];
        end
       else
        begin
          for i:=1 to length(s) do
           begin
             case s[i] of
               '/','\' :
                  FixFileName[i]:=source_info.dirsep;
               'A'..'Z' :
                  FixFileName[i]:=char(byte(s[i])+32);
                else
                  FixFileName[i]:=s[i];
             end;
           end;
          FixFileName[0]:=s[0];
        end;
     end;


    Function TargetFixPath(s:string;allowdot:boolean):string;
      var
        i : longint;
      begin
        { Fix separator }
        for i:=1 to length(s) do
         if s[i] in ['/','\'] then
          s[i]:=target_info.DirSep;
        { Fix ending / }
        if (length(s)>0) and (s[length(s)]<>target_info.DirSep) and
           (s[length(s)]<>':') then
         s:=s+target_info.DirSep;
        { Remove ./ }
        if (not allowdot) and (s='.'+target_info.DirSep) then
         s:='';
        { return }
        if target_info.files_case_relevent then
         TargetFixPath:=s
        else
         TargetFixPath:=Lower(s);
      end;


   function TargetFixFileName(const s:string):string;
     var
       i : longint;
     begin
       if target_info.system = system_powerpc_MACOS then
         TargetFixFileName:= TranslatePathToMac(s, true)
       else if target_info.files_case_relevent then
         begin
           for i:=1 to length(s) do
           begin
             case s[i] of
               '/','\' :
                 TargetFixFileName[i]:=target_info.dirsep;
               else
                 TargetFixFileName[i]:=s[i];
             end;
           end;
           TargetFixFileName[0]:=s[0];
         end
       else
         begin
           for i:=1 to length(s) do
           begin
             case s[i] of
               '/','\' :
                  TargetFixFileName[i]:=target_info.dirsep;
               'A'..'Z' :
                  TargetFixFileName[i]:=char(byte(s[i])+32);
                else
                  TargetFixFileName[i]:=s[i];
             end;
           end;
           TargetFixFileName[0]:=s[0];
         end;
     end;


   procedure SplitBinCmd(const s:string;var bstr:String;var cstr:TCmdStr);
     var
       i : longint;
     begin
       i:=pos(' ',s);
       if i>0 then
        begin
          bstr:=Copy(s,1,i-1);
          cstr:=Copy(s,i+1,length(s)-i);
        end
       else
        begin
          bstr:=s;
          cstr:='';
        end;
     end;

  procedure TSearchPathList.AddPath(s:string;addfirst:boolean);
    begin
      AddPath('',s,AddFirst);
    end;

   procedure TSearchPathList.AddPath(SrcPath,s:string;addfirst:boolean);
     var
       staridx,
       j        : longint;
       prefix,
       suffix,
       CurrentDir,
       currPath : string;
       subdirfound : boolean;
{$IFDEF USE_SYSUTILS}
       dir      : TSearchRec;
{$ELSE USE_SYSUTILS}
       dir      : searchrec;
{$ENDIF USE_SYSUTILS}
       hp       : TStringListItem;

       procedure AddCurrPath;
       begin
         if addfirst then
          begin
            Remove(currPath);
            Insert(currPath);
          end
         else
          begin
            { Check if already in path, then we don't add it }
            hp:=Find(currPath);
            if not assigned(hp) then
             Concat(currPath);
          end;
       end;

     begin
       if s='' then
        exit;
     { Support default macro's }
       DefaultReplacements(s);
     { get current dir }
       CurrentDir:=GetCurrentDir;
       repeat
         { get currpath }
         if addfirst then
          begin
            j:=length(s);
            while (j>0) and (s[j]<>';') do
             dec(j);
            currPath:= TrimSpace(Copy(s,j+1,length(s)-j));
            DePascalQuote(currPath);
            currPath:=FixPath(currPath,false);
            if j=0 then
             s:=''
            else
             System.Delete(s,j,length(s)-j+1);
          end
         else
          begin
            j:=Pos(';',s);
            if j=0 then
             j:=255;
            currPath:= TrimSpace(Copy(s,1,j-1));
            DePascalQuote(currPath);
            currPath:=SrcPath+FixPath(currPath,false);
            System.Delete(s,1,j);
          end;

         { fix pathname }
         if currPath='' then
           currPath:= CurDirRelPath(source_info)
         else
          begin
{$ifdef USE_SYSUTILS}
            currPath:=FixPath(ExpandFileName(currpath),false);
{$else USE_SYSUTILS}
            currPath:=FixPath(FExpand(currPath),false);
{$endif USE_SYSUTILS}
            if (CurrentDir<>'') and (Copy(currPath,1,length(CurrentDir))=CurrentDir) then
             begin
{$ifdef AMIGA}
               currPath:= CurrentDir+Copy(currPath,length(CurrentDir)+1,255);
{$else}
               currPath:= CurDirRelPath(source_info)+Copy(currPath,length(CurrentDir)+1,255);
{$endif}
             end;
          end;
         { wildcard adding ? }
         staridx:=pos('*',currpath);
         if staridx>0 then
          begin
            prefix:=SplitPath(Copy(currpath,1,staridx));
            suffix:=Copy(currpath,staridx+1,length(currpath));
            subdirfound:=false;
{$IFDEF USE_SYSUTILS}
            if findfirst(prefix+'*',faDirectory,dir) = 0 then
              begin
                repeat
                  if (dir.name<>'.') and
                      (dir.name<>'..') and
                      ((dir.attr and faDirectory)<>0) then
                    begin
                      subdirfound:=true;
                      currpath:=prefix+dir.name+suffix;
                      if (suffix='') or PathExists(currpath) then
                        begin
                          hp:=Find(currPath);
                          if not assigned(hp) then
                            AddCurrPath;
                        end;
                    end;
                until findnext(dir) <> 0;
              end;
{$ELSE USE_SYSUTILS}
            findfirst(prefix+'*',directory,dir);
            while doserror=0 do
             begin
               if (dir.name<>'.') and
                  (dir.name<>'..') and
                  ((dir.attr and directory)<>0) then
                begin
                  subdirfound:=true;
                  currpath:=prefix+dir.name+suffix;
                  if (suffix='') or PathExists(currpath) then
                    begin
                      hp:=Find(currPath);
                      if not assigned(hp) then
                        AddCurrPath;
                    end;
                end;
               findnext(dir);
             end;
{$ENDIF USE_SYSUTILS}
            FindClose(dir);
            if not subdirfound then
              WarnNonExistingPath(currpath);
          end
         else
          begin
            if PathExists(currpath) then
             AddCurrPath
            else
             WarnNonExistingPath(currpath);
          end;
       until (s='');
     end;


   procedure TSearchPathList.AddList(list:TSearchPathList;addfirst:boolean);
     var
       s : string;
       hl : TSearchPathList;
       hp,hp2 : TStringListItem;
     begin
       if list.empty then
        exit;
       { create temp and reverse the list }
       if addfirst then
        begin
          hl:=TSearchPathList.Create;
          hp:=TStringListItem(list.first);
          while assigned(hp) do
           begin
             hl.insert(hp.Str);
             hp:=TStringListItem(hp.next);
           end;
          while not hl.empty do
           begin
             s:=hl.GetFirst;
             Remove(s);
             Insert(s);
           end;
          hl.Free;
        end
       else
        begin
          hp:=TStringListItem(list.first);
          while assigned(hp) do
           begin
             hp2:=Find(hp.Str);
             { Check if already in path, then we don't add it }
             if not assigned(hp2) then
              Concat(hp.Str);
             hp:=TStringListItem(hp.next);
           end;
        end;
     end;


   function TSearchPathList.FindFile(const f : string;var foundfile:string):boolean;
     Var
       p : TStringListItem;
     begin
       FindFile:=false;
       p:=TStringListItem(first);
       while assigned(p) do
        begin
          result:=FileExistsNonCase(p.Str,f,FoundFile);
          if result then
            exit;
          p:=TStringListItem(p.next);
        end;
       { Return original filename if not found }
       FoundFile:=f;
     end;


   Function GetFileTime ( Var F : File) : Longint;
     Var
     {$ifdef hasunix}
        info: Stat;
     {$endif}
       L : longint;
     begin
     {$ifdef hasunix}
       {$IFDEF havelinuxrtl10}
        FStat (F,Info);
        L:=Info.Mtime;
       {$ELSE}
        FPFStat (F,Info);
        L:=Info.st_Mtime;
       {$ENDIF}
     {$else}
       GetFTime(f,l);
     {$endif}
       GetFileTime:=L;
     end;


   Function GetNamedFileTime (Const F : String) : Longint;
     begin
       GetNamedFileTime:=do_getnamedfiletime(F);
     end;


   function FindFile(const f : string;path : string;var foundfile:string):boolean;
      Var
        singlepathstring : string;
        i : longint;
     begin
{$ifdef Unix}
       for i:=1 to length(path) do
        if path[i]=':' then
         path[i]:=';';
{$endif Unix}
       FindFile:=false;
       repeat
          i:=pos(';',path);
          if i=0 then
           i:=256;
          singlepathstring:=FixPath(copy(path,1,i-1),false);
          delete(path,1,i);
          result:=FileExistsNonCase(singlepathstring,f,FoundFile);
          if result then
            exit;
       until path='';
       FoundFile:=f;
     end;


   function FindFilePchar(const f : string;path : pchar;var foundfile:string):boolean;
      Var
        singlepathstring : string;
        startpc,pc : pchar;
        sepch : char;
     begin
       FindFilePchar:=false;
       if Assigned (Path) then
        begin
{$ifdef Unix}
          sepch:=':';
{$else}
{$ifdef macos}
          sepch:=',';
{$else}
          sepch:=';';
{$endif macos}
{$endif Unix}
          pc:=path;
          repeat
             startpc:=pc;
             while (pc^<>sepch) and (pc^<>';') and (pc^<>#0) do
              inc(pc);
             move(startpc^,singlepathstring[1],pc-startpc);
             singlepathstring[0]:=char(longint(pc-startpc));
             singlepathstring:=FixPath(singlepathstring,false);
             result:=FileExistsNonCase(singlepathstring,f,FoundFile);
             if result then
               exit;
             if (pc^=#0) then
               break;
             inc(pc);
          until false;
        end;
       foundfile:=f;
     end;


   function  FindExe(const bin:string;var foundfile:string):boolean;
     var
       p : pchar;
       found : boolean;
     begin
       found:=FindFile(FixFileName(AddExtension(bin,source_info.exeext)),'.;'+exepath,foundfile);
       if not found then
        begin
{$ifdef macos}
          p:=GetEnvPchar('Commands');
{$else}
          p:=GetEnvPchar('PATH');
{$endif}
          found:=FindFilePChar(FixFileName(AddExtension(bin,source_info.exeext)),p,foundfile);
          FreeEnvPChar(p);
        end;
       FindExe:=found;
     end;


    function GetShortName(const n:string):string;
{$ifdef win32}
      var
        hs,hs2 : string;
        i : longint;
{$endif}
{$ifdef go32v2}
      var
        hs : string;
{$endif}
{$ifdef watcom}
      var
        hs : string;
{$endif}
      begin
        GetShortName:=n;
{$ifdef win32}
        hs:=n+#0;
        i:=Windows.GetShortPathName(@hs[1],@hs2[1],high(hs2));
        if (i>0) and (i<=high(hs2)) then
          begin
            hs2[0]:=chr(strlen(@hs2[1]));
            GetShortName:=hs2;
          end;
{$endif}
{$ifdef go32v2}
        hs:=n;
        if Dos.GetShortName(hs) then
         GetShortName:=hs;
{$endif}
{$ifdef watcom}
        hs:=n;
        if Dos.GetShortName(hs) then
         GetShortName:=hs;
{$endif}
      end;


function  CleanPath(const s:string):String;
{ Wrapper that encapsulate fexpand/expandfilename}
begin
{$IFDEF USE_SYSUTILS}
 cleanpath:=ExpandFileName(s);
{$else}
 cleanpath:=fexpand(s);
{$endif}
end;
 {****************************************************************************
                               OS Dependent things
 ****************************************************************************}

    function GetEnvPChar(const envname:string):pchar;
      {$ifdef win32}
      var
        s     : string;
        i,len : longint;
        hp,p,p2 : pchar;
      {$endif}
      begin
      {$ifdef hasunix}
        GetEnvPchar:={$ifdef havelinuxrtl10}Linux.getenv{$else}BaseUnix.fpGetEnv{$endif}(envname);
        {$define GETENVOK}
      {$endif}
      {$ifdef win32}
        GetEnvPchar:=nil;
        p:=GetEnvironmentStrings;
        hp:=p;
        while hp^<>#0 do
         begin
           s:=strpas(hp);
           i:=pos('=',s);
           len:=strlen(hp);
           if upper(copy(s,1,i-1))=upper(envname) then
            begin
              GetMem(p2,len-length(envname));
              Move(hp[i],p2^,len-length(envname));
              GetEnvPchar:=p2;
              break;
            end;
           { next string entry}
           hp:=hp+len+1;
         end;
        FreeEnvironmentStrings(p);
        {$define GETENVOK}
      {$endif}
      {$ifdef os2}
        GetEnvPChar := Dos.GetEnvPChar (EnvName);
        {$define GETENVOK}
      {$endif}
      {$ifdef GETENVOK}
        {$undef GETENVOK}
      {$else}
        GetEnvPchar:=StrPNew(Dos.Getenv(envname));
      {$endif}
      end;


    procedure FreeEnvPChar(p:pchar);
      begin
      {$ifndef hasunix}
       {$ifndef os2}
        StrDispose(p);
       {$endif}
      {$endif}
      end;

{$IFDEF MORPHOS}
{$DEFINE AMIGASHELL}
{$ENDIF}
{$IFDEF AMIGA}
{$DEFINE AMIGASHELL}
{$ENDIF}

    function Shell(const command:string): longint;
      { This is already defined in the linux.ppu for linux, need for the *
        expansion under linux }
      {$ifdef hasunix}
      begin
        result := {$ifdef havelinuxrtl10}Linux{$else}Unix{$endif}.Shell(command);
      end;
      {$else}
      {$ifdef amigashell}
      begin
{$IFDEF USE_SYSUTILS}
        result := ExecuteProcess('',command);
{$ELSE USE_SYSUTILS}
        exec('',command);
        if (doserror <> 0) then
          result := doserror
        else
          result := dosexitcode;
      end;
{$ENDIF USE_SYSUTILS}
      {$else}
      var
        comspec : string;
      begin
        comspec:=getenv('COMSPEC');
{$IFDEF USE_SYSUTILS}
        result := ExecuteProcess(comspec,' /C '+command);
{$ELSE USE_SYSUTILS}
        Exec(comspec,' /C '+command);
        if (doserror <> 0) then
          result := doserror
        else
          result := dosexitcode;
      end;
{$ENDIF USE_SYSUTILS}
      {$endif}
      {$endif}

{$UNDEF AMIGASHELL}

{$ifdef CPUI386}
  {$define HASSETFPUEXCEPTIONMASK}
      { later, this should be replaced by the math unit }
      const
        Default8087CW : word = $1332;

      procedure Set8087CW(cw:word);assembler;
        asm
          movw cw,%ax
          movw %ax,default8087cw
          fnclex
          fldcw default8087cw
        end;


      function Get8087CW:word;assembler;
        asm
          pushl $0
          fnstcw (%esp)
          popl %eax
        end;


      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
        var
          CtlWord: Word;
        begin
          CtlWord:=Get8087CW;
          Set8087CW( (CtlWord and $FFC0) or Byte(Longint(Mask)) );
        end;
{$endif CPUI386}

{$ifdef CPUX86_64}
  {$define HASSETFPUEXCEPTIONMASK}
      { later, this should be replaced by the math unit }
      const
        Default8087CW : word = $1332;

      procedure Set8087CW(cw:word);assembler;
        asm
          movw cw,%ax
          movw %ax,default8087cw
          fnclex
          fldcw default8087cw
        end;


      function Get8087CW:word;assembler;
        asm
          pushq $0
          fnstcw (%rsp)
          popq %rax
        end;


      procedure SetSSECSR(w : dword);
        var
          _w : dword;
        begin
          _w:=w;
          asm
            ldmxcsr _w
          end;
        end;


      function GetSSECSR : dword;
          var
            _w : dword;
          begin
            asm
              stmxcsr _w
            end;
            result:=_w;
          end;


      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
        var
          CtlWord: Word;
          newmask : dword;
        const
          MM_MaskInvalidOp = %0000000010000000;
          MM_MaskDenorm    = %0000000100000000;
          MM_MaskDivZero   = %0000001000000000;
          MM_MaskOverflow  = %0000010000000000;
          MM_MaskUnderflow = %0000100000000000;
          MM_MaskPrecision = %0001000000000000;
        begin
          { classic FPU }
          CtlWord:=Get8087CW;
          Set8087CW( (CtlWord and $FFC0) or Byte(Longint(Mask)) );

          { SSE }

          newmask:=GetSSECSR;

          { invalid operation }
          if (exInvalidOp in mask) then
            newmask:=newmask or MM_MaskInvalidOp
          else
            newmask:=newmask and not(MM_MaskInvalidOp);

          { denormals }
          if (exDenormalized in mask) then
            newmask:=newmask or MM_MaskDenorm
          else
            newmask:=newmask and not(MM_MaskDenorm);

          { zero divide }
          if (exZeroDivide in mask) then
            newmask:=newmask or MM_MaskDivZero
          else
            newmask:=newmask and not(MM_MaskDivZero);

          { overflow }
          if (exOverflow in mask) then
            newmask:=newmask or MM_MaskOverflow
          else
            newmask:=newmask and not(MM_MaskOverflow);

          { underflow }
          if (exUnderflow in mask) then
            newmask:=newmask or MM_MaskUnderflow
          else
            newmask:=newmask and not(MM_MaskUnderflow);

          { Precision (inexact result) }
          if (exPrecision in mask) then
            newmask:=newmask or MM_MaskPrecision
          else
            newmask:=newmask and not(MM_MaskPrecision);
          SetSSECSR(newmask);
        end;
{$endif CPUX86_64}

{$ifdef CPUPOWERPC}
  {$define HASSETFPUEXCEPTIONMASK}
      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
        var
          newmask: record
            case byte of
               1: (d: double);
               2: (a,b: cardinal);
            end;
        begin
          { load current control register contents }
          asm
            mffs f0
            stfd f0,newmask.d
          end;
          { invalid operation: bit 24 (big endian, bit 0 = left-most bit) }
          if (exInvalidOp in mask) then
            newmask.b := newmask.b and not(1 shl (31-24))
          else
            newmask.b := newmask.b or (1 shl (31-24));

          { denormals can not cause exceptions on the PPC }

          { zero divide: bit 27 }
          if (exZeroDivide in mask) then
            newmask.b := newmask.b and not(1 shl (31-27))
          else
            newmask.b := newmask.b or (1 shl (31-27));

          { overflow: bit 25 }
          if (exOverflow in mask) then
            newmask.b := newmask.b and not(1 shl (31-25))
          else
            newmask.b := newmask.b or (1 shl (31-25));

          { underflow: bit 26 }
          if (exUnderflow in mask) then
            newmask.b := newmask.b and not(1 shl (31-26))
          else
            newmask.b := newmask.b or (1 shl (31-26));

          { Precision (inexact result): bit 28 }
          if (exPrecision in mask) then
            newmask.b := newmask.b and not(1 shl (31-28))
          else
            newmask.b := newmask.b or (1 shl (31-28));
          { update control register contents }
          asm
            lfd   f0, newmask.d
            mtfsf 255,f0
          end;
        end;
{$endif CPUPOWERPC}

{$ifdef CPUSPARC}
  {$define HASSETFPUEXCEPTIONMASK}
      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
        var
          fsr : cardinal;
        begin
          { load current control register contents }
          asm
            st %fsr,fsr
          end;
          { invalid operation: bit 27 }
          if (exInvalidOp in mask) then
            fsr:=fsr and not(1 shl 27)
          else
            fsr:=fsr or (1 shl 27);

          { zero divide: bit 24 }
          if (exZeroDivide in mask) then
            fsr:=fsr and not(1 shl 24)
          else
            fsr:=fsr or (1 shl 24);

          { overflow: bit 26 }
          if (exOverflow in mask) then
            fsr:=fsr and not(1 shl 26)
          else
            fsr:=fsr or (1 shl 26);

          { underflow: bit 25 }
          if (exUnderflow in mask) then
            fsr:=fsr and not(1 shl 25)
          else
            fsr:=fsr or (1 shl 25);

          { Precision (inexact result): bit 23 }
          if (exPrecision in mask) then
            fsr:=fsr and not(1 shl 23)
          else
            fsr:=fsr or (1 shl 23);
          { update control register contents }
          asm
            ld fsr,%fsr
          end;
        end;
{$endif CPUSPARC}

{$ifndef HASSETFPUEXCEPTIONMASK}
      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
        begin
        end;
{$endif HASSETFPUEXCEPTIONMASK}

      function is_number_float(d : double) : boolean;
        var
           bytearray : array[0..7] of byte;
        begin
          move(d,bytearray,8);
          { only 1.1 save, 1.0.x will use always little endian }
{$ifdef FPC_BIG_ENDIAN}
          result:=((bytearray[0] and $7f)<>$7f) or ((bytearray[1] and $f0)<>$f0);
{$else FPC_BIG_ENDIAN}
          result:=((bytearray[7] and $7f)<>$7f) or ((bytearray[6] and $f0)<>$f0);
{$endif FPC_BIG_ENDIAN}
        end;


    function convertdoublearray(d : tdoublearray) : tdoublearray;{$ifdef USEINLINE}inline;{$endif}
{$ifdef CPUARM}
      var
        i : longint;
      begin
        for i:=0 to 3 do
          begin
            result[i+4]:=d[i];
            result[i]:=d[i+4];
          end;
{$else CPUARM}
      begin
        result:=d;
{$endif CPUARM}
      end;


    function SetAktProcCall(const s:string; changeInit:boolean):boolean;
      const
        DefProcCallName : array[tproccalloption] of string[12] = ('',
         'CDECL',
         'CPPDECL',
         'FAR16',
         'OLDFPCCALL',
         '', { internproc }
         '', { syscall }
         'PASCAL',
         'REGISTER',
         'SAFECALL',
         'STDCALL',
         'SOFTFLOAT',
         'MWPASCAL'
        );
      var
        t : tproccalloption;
      begin
        result:=false;
        for t:=low(tproccalloption) to high(tproccalloption) do
         if DefProcCallName[t]=s then
          begin
            AktDefProcCall:=t;
            result:=true;
            break;
          end;
        if changeinit then
         InitDefProcCall:=AktDefProcCall;
      end;


    function SetProcessor(const s:string; changeInit: boolean):boolean;
      var
        t : tprocessors;
      begin
        SetProcessor:=false;
        for t:=low(tprocessors) to high(tprocessors) do
          if processorsstr[t]=s then
            begin
              aktspecificoptprocessor:=t;
              SetProcessor:=true;
              break;
            end;
        if changeinit then
          initspecificoptprocessor:=aktspecificoptprocessor;
      end;


    function SetFpuType(const s:string; changeInit: boolean):boolean;
      var
        t : tfputype;
      begin
        SetFpuType:=false;
        for t:=low(tfputype) to high(tfputype) do
          if fputypestr[t]=s then
            begin
              aktfputype:=t;
              SetFpuType:=true;
              break;
            end;
        if changeinit then
          initfputype:=aktfputype;
      end;


    { '('D1:'00000000-'D2:'0000-'D3:'0000-'D4:'0000-000000000000)' }
    function string2guid(const s: string; var GUID: TGUID): boolean;
        function ishexstr(const hs: string): boolean;
          var
            i: integer;
          begin
            ishexstr:=false;
            for i:=1 to Length(hs) do begin
              if not (hs[i] in ['0'..'9','A'..'F','a'..'f']) then
                exit;
            end;
            ishexstr:=true;
          end;
        function hexstr2longint(const hexs: string): longint;
          var
            i: integer;
            rl: longint;
          begin
            rl:=0;
            for i:=1 to length(hexs) do begin
              rl:=rl shl 4;
              case hexs[i] of
                '0'..'9' : inc(rl,ord(hexs[i])-ord('0'));
                'A'..'F' : inc(rl,ord(hexs[i])-ord('A')+10);
                'a'..'f' : inc(rl,ord(hexs[i])-ord('a')+10);
              end
            end;
            hexstr2longint:=rl;
          end;
      var
        i: integer;
      begin
        if (Length(s)=38) and (s[1]='{') and (s[38]='}') and
           (s[10]='-') and (s[15]='-') and (s[20]='-') and (s[25]='-') and
           ishexstr(copy(s,2,8)) and ishexstr(copy(s,11,4)) and
           ishexstr(copy(s,16,4)) and ishexstr(copy(s,21,4)) and
           ishexstr(copy(s,26,12)) then begin
          GUID.D1:=dword(hexstr2longint(copy(s,2,8)));
          { these values are arealdy in the correct range (4 chars = word) }
          GUID.D2:=word(hexstr2longint(copy(s,11,4)));
          GUID.D3:=word(hexstr2longint(copy(s,16,4)));
          for i:=0 to 1 do
            GUID.D4[i]:=byte(hexstr2longint(copy(s,21+i*2,2)));
          for i:=2 to 7 do
            GUID.D4[i]:=byte(hexstr2longint(copy(s,22+i*2,2)));
          string2guid:=true;
        end
        else
          string2guid:=false;
      end;

    function guid2string(const GUID: TGUID): string;
        function long2hex(l, len: longint): string;
          const
            hextbl: array[0..15] of char = '0123456789ABCDEF';
          var
            rs: string;
            i: integer;
          begin
            rs[0]:=chr(len);
            for i:=len downto 1 do begin
              rs[i]:=hextbl[l and $F];
              l:=l shr 4;
            end;
            long2hex:=rs;
          end;
      begin
        guid2string:=
          '{'+long2hex(GUID.D1,8)+
          '-'+long2hex(GUID.D2,4)+
          '-'+long2hex(GUID.D3,4)+
          '-'+long2hex(GUID.D4[0],2)+long2hex(GUID.D4[1],2)+
          '-'+long2hex(GUID.D4[2],2)+long2hex(GUID.D4[3],2)+
              long2hex(GUID.D4[4],2)+long2hex(GUID.D4[5],2)+
              long2hex(GUID.D4[6],2)+long2hex(GUID.D4[7],2)+
          '}';
      end;


    function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
      var
        tok  : string;
        vstr : string;
        l    : longint;
        code : integer;
        b    : talignmentinfo;
      begin
        UpdateAlignmentStr:=true;
        uppervar(s);
        fillchar(b,sizeof(b),0);
        repeat
          tok:=GetToken(s,'=');
          if tok='' then
           break;
          vstr:=GetToken(s,',');
          val(vstr,l,code);
          if tok='PROC' then
           b.procalign:=l
          else if tok='JUMP' then
           b.jumpalign:=l
          else if tok='LOOP' then
           b.loopalign:=l
          else if tok='CONSTMIN' then
           b.constalignmin:=l
          else if tok='CONSTMAX' then
           b.constalignmax:=l
          else if tok='VARMIN' then
           b.varalignmin:=l
          else if tok='VARMAX' then
           b.varalignmax:=l
          else if tok='LOCALMIN' then
           b.localalignmin:=l
          else if tok='LOCALMAX' then
           b.localalignmax:=l
          else if tok='RECORDMIN' then
           b.recordalignmin:=l
          else if tok='RECORDMAX' then
           b.recordalignmax:=l
          else { Error }
           UpdateAlignmentStr:=false;
        until false;
        UpdateAlignment(a,b);
      end;


    function var_align(siz: longint): longint;
      begin
        siz := size_2_align(siz);
        var_align := used_align(siz,aktalignment.varalignmin,aktalignment.varalignmax);
      end;


    function const_align(siz: longint): longint;
      begin
        siz := size_2_align(siz);
        const_align := used_align(siz,aktalignment.constalignmin,aktalignment.constalignmax);
      end;


{****************************************************************************
                                    Init
****************************************************************************}

{$ifdef unix}
  {$define need_path_search}
{$endif unix}
{$ifdef os2}
  {$define need_path_search}
{$endif os2}
{$ifdef macos}
  {$define need_path_search}
{$endif macos}

   procedure get_exepath;
     var
       hs1 : namestr;
       hs2 : extstr;
{$IFDEF USE_SYSUTILS}
       exeName:String;
{$ENDIF USE_SYSUTILS}
{$ifdef need_path_search}
       p   : pchar;
{$endif need_path_search}
     begin
{$IFDEF USE_SYSUTILS}
       exepath:=GetEnvironmentVariable('PPC_EXEC_PATH');
{$ELSE USE_SYSUTILS}
       exepath:=dos.getenv('PPC_EXEC_PATH');
{$ENDIF USE_SYSUTILS}
       if exepath='' then
{$IFDEF USE_SYSUTILS}
        exeName := FixFileName(system.paramstr(0));
        exepath := ExtractFilePath(exeName);
        hs1 := ExtractFileName(exeName);
        hs2 := ExtractFileExt(exeName);
{$ELSE USE_SYSUTILS}
        fsplit(FixFileName(system.paramstr(0)),exepath,hs1,hs2);
{$ENDIF USE_SYSUTILS}
{$ifdef need_path_search}
       if exepath='' then
        begin
          if pos(source_info.exeext,hs1) <>
               (length(hs1) - length(source_info.exeext)+1) then
            hs1 := hs1 + source_info.exeext;
{$ifdef macos}
          p:=GetEnvPchar('Commands');
{$else macos}
          p:=GetEnvPchar('PATH');
{$endif macos}
          FindFilePChar(hs1,p,exepath);
          FreeEnvPChar(p);
          exepath:=SplitPath(exepath);
        end;
{$endif need_path_search}
       exepath:=FixPath(exepath,false);
     end;



   procedure DoneGlobals;
     begin
       if assigned(DLLImageBase) then
         StringDispose(DLLImageBase);
       librarysearchpath.Free;
       unitsearchpath.Free;
       objectsearchpath.Free;
       includesearchpath.Free;
     end;

   procedure InitGlobals;
     begin
        get_exepath;

      { reset globals }
        do_build:=false;
        do_release:=false;
        do_make:=true;
        compile_level:=0;
        DLLsource:=false;
        inlining_procedure:=false;
        resolving_forward:=false;
        make_ref:=false;
        LinkTypeSetExplicitly:=false;
        paratarget:=system_none;
        paratargetasm:=as_none;
        paratargetdbg:=dbg_none;

      { Output }
        OutputFile:='';
        OutputPrefix:=Nil;
        OutputSuffix:=Nil;
        OutputExtension:='';

        OutputExeDir:='';
        OutputUnitDir:='';

      { Utils directory }
        utilsdirectory:='';
        utilsprefix:='';
        cshared:=false;
        rlinkpath:='';

      { Search Paths }
        librarysearchpath:=TSearchPathList.Create;
        unitsearchpath:=TSearchPathList.Create;
        includesearchpath:=TSearchPathList.Create;
        objectsearchpath:=TSearchPathList.Create;

      { Def file }
        usewindowapi:=false;
        description:='Compiled by FPC '+version_string+' - '+target_cpu_string;
        DescriptionSetExplicity:=false;
        dllversion:='';
        dllmajor:=1;
        dllminor:=0;
        dllrevision:=0;
        nwscreenname := '';
        nwthreadname := '';
        nwcopyright  := '';
        UseDeffileForExports:=false;
        UseDeffileForExportsSetExplicitly:=false;
        RelocSection:=false;
        RelocSectionSetExplicitly:=false;
        LinkTypeSetExplicitly:=false;

      { Init values }
        initmodeswitches:=fpcmodeswitches;
        initlocalswitches:=[cs_check_io,cs_typed_const_writable];
        initmoduleswitches:=[cs_extsyntax,cs_implicit_exceptions];
        initsourcecodepage:='8859-1';
        initglobalswitches:=[cs_check_unit_name,cs_link_static{$ifdef INTERNALLINKER},cs_link_internal,cs_link_map{$endif}];
        fillchar(initalignment,sizeof(talignmentinfo),0);
        { might be overridden later }
        initasmmode:=asmmode_standard;
{$ifdef i386}
        initoptprocessor:=ClassPentium3;
        initspecificoptprocessor:=Class386;

        initfputype:=fpu_x87;

        initpackenum:=4;
        {$IFDEF testvarsets}
        initsetalloc:=0;
        {$ENDIF}
        initasmmode:=asmmode_i386_att;
{$endif i386}
{$ifdef m68k}
        initoptprocessor:=MC68020;
        initpackenum:=4;
        {$IFDEF testvarsets}
         initsetalloc:=0;
        {$ENDIF}
{$endif m68k}
{$ifdef powerpc}
        initoptprocessor:=PPC604;
        initpackenum:=4;
        {$IFDEF testvarsets}
         initsetalloc:=0;
        {$ENDIF}
        initfputype:=fpu_standard;
{$endif powerpc}
{$ifdef POWERPC64}
        initoptprocessor:=PPC970;
        initpackenum:=4;
        {$IFDEF testvarsets}
         initsetalloc:=0;
        {$ENDIF}
        initfputype:=fpu_standard;
{$endif POWERPC64}
{$ifdef sparc}
        initoptprocessor:=SPARC_V8;
        initpackenum:=4;
        {$IFDEF testvarsets}
         initsetalloc:=0;
        {$ENDIF}
{$endif sparc}
{$ifdef arm}
        initpackenum:=4;
        {$IFDEF testvarsets}
        initsetalloc:=0;
        {$ENDIF}
        initfputype:=fpu_fpa;
{$endif arm}
{$ifdef x86_64}
        initoptprocessor:=ClassAthlon64;
        initspecificoptprocessor:=ClassAthlon64;

        initfputype:=fpu_sse64;

        initpackenum:=4;
        {$IFDEF testvarsets}
        initsetalloc:=0;
        {$ENDIF}
        initasmmode:=asmmode_x86_64_gas;
{$endif x86_64}
        initinterfacetype:=it_interfacecom;
        initdefproccall:=pocall_default;

      { memory sizes, will be overriden by parameter or default for target
        in options or init_parser }
        stacksize:=0;
        { not initialized yet }
        jmp_buf_size:=-1;

        apptype:=app_cui;
     end;

end.