diff options
Diffstat (limited to 'compiler/globals.pas')
| -rw-r--r-- | compiler/globals.pas | 2245 |
1 files changed, 2245 insertions, 0 deletions
diff --git a/compiler/globals.pas b/compiler/globals.pas new file mode 100644 index 0000000000..21721ac164 --- /dev/null +++ b/compiler/globals.pas @@ -0,0 +1,2245 @@ +{ + 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. |