home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / globals.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-09-24  |  36.4 KB  |  1,307 lines
  1. {
  2.     $Id: globals.pas,v 1.6.2.7 1998/08/18 13:41:22 carl Exp $
  3.     Copyright (C) 1993-98 by Florian Klaempfl
  4.  
  5.     This unit implements some support functions and global variables
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23.  
  24. {$ifdef tp}
  25.   {$E+,N+}
  26. {$endif}
  27.  
  28. unit globals;
  29.  
  30.   interface
  31.  
  32.     uses
  33.       cobjects,objects,dos,strings
  34. {$ifdef linux}
  35.       ,linux
  36. {$endif}
  37.       ;
  38.  
  39. {$I version.inc}
  40.  
  41.     type
  42.        { later moved to system unit }
  43.        aword = longint;
  44. { for each processor define the best precision }
  45. {$ifdef i386}
  46.   {$ifdef ver_above0_9_8}
  47.        bestreal = extended;
  48.   {$else ver_above0_9_8}
  49.        bestreal = double;
  50.   {$endif ver_above0_9_8}
  51. {$endif i386}
  52. {$ifdef m68k}
  53.        bestreal = real;
  54. {$endif m68k}
  55.  
  56.  
  57.     const
  58.        { version string }
  59.        version_nr = '0';
  60.        release_nr = '99';
  61.        patch_nr   = '5';
  62. {$ifdef i386}
  63.        target = 'i386';
  64. {$endif}
  65. {$ifdef m68k}
  66.        target = 'M680x0';
  67. {$endif}
  68. {$ifdef alpha}
  69.        target = 'Alpha';
  70. {$endif}
  71.        version_string = version_nr+'.'+release_nr+'.'+patch_nr+' for '+target;
  72.  
  73. {$ifdef Splitheap}
  74.        testsplit : boolean = false;
  75. {$endif Splitheap}
  76.  
  77.        { max. significant length of strings }
  78.        maxidlen = 64;
  79.  
  80.     type
  81.        { I had to change the order for overloading
  82.          can this be a problem ? (PM)
  83.  
  84.          It will be no problem, if you change also the array to convert
  85.          tokens to strings (in PARSER.PAS) (FK)
  86.        }
  87.  
  88. {***IMPLIBGEN}
  89.        ttoken = (PLUS,MINUS,STAR,SLASH,EQUAL,GT,LT,GTE,LTE,_IS,_AS,_IN,
  90.                  SYMDIF,CARET,
  91.                  ASSIGNMENT,UNEQUAL,LECKKLAMMER,RECKKLAMMER,
  92.                  POINT,COMMA,LKLAMMER,RKLAMMER,COLON,SEMICOLON,
  93.                  KLAMMERAFFE,POINTPOINT,
  94.                  ID,REALNUMBER,_EOF,INTCONST,CSTRING,CCHAR,DOUBLEADDR,
  95.  
  96. {                _ABSOLUTE,}
  97.                  _AND,_ARRAY,_ASM,_BEGIN,
  98.                  _BREAK,_CASE,_CONST,_CONSTRUCTOR,_CONTINUE,
  99.                  _DESTRUCTOR,_DISPOSE,_DIV,_DO,_DOWNTO,_ELSE,_END,
  100.                  _EXIT,
  101. {                _EXPORT,}
  102.                  _EXTERNAL,_FAIL,_FALSE,
  103. {                _FAR,}
  104.                  _FILE,_FOR,
  105. {                _FORWARD,}
  106.                  _FUNCTION,_GOTO,_IF,_IMPLEMENTATION,
  107.                  _INHERITED,
  108. {                _INLINE,}
  109.                  _INTERFACE,
  110. {                _INTERRUPT,}
  111.                  _LABEL,_MOD,
  112. {                _NEAR,}
  113.                  _NEW,_NIL,_NOT,_OBJECT,
  114.                  _OF,_OTHERWISE,_OR,_PACKED,
  115.                  _PROCEDURE,_PROGRAM,
  116.                  _RECORD,_REPEAT,_SELF,
  117.                  _SET,_SHL,_SHR,_STRING,_THEN,_TO,
  118.                  _TRUE,_TYPE,_UNIT,_UNTIL,
  119.                  _USES,_VAR,_WHILE,_WITH,_XOR,
  120.                  { since Delphi 2 }
  121.                  _CLASS,_EXCEPT,_TRY,_ON,
  122. {                _ABSTRACT,}
  123.                  _LIBRARY,_INITIALIZATION,_FINALLY,_EXPORTS,_PROPERTY,
  124.                  _RAISE,
  125.                  { for operator overloading }
  126.                  _OPERATOR,
  127.  
  128.                  { C like operators }
  129.                  _PLUSASN,_MINUSASN,_ANDASN,_ORASN,_STARASN,_SLASHASN,
  130.                  _MODASN,_DIVASN,_NOTASN,_XORASN
  131.                  );
  132.  
  133.        tcswitch = (cs_none,
  134.          cs_check_overflow,cs_maxoptimieren,cs_uncertainopts,
  135.          cs_omitstackframe,cs_littlesize,cs_optimize,cs_debuginfo,
  136.          cs_compilesystem,cs_rangechecking,cs_support_goto,
  137.          cs_check_unit_name,cs_iocheck,cs_checkconsname,
  138.          cs_check_stack,cs_extsyntax,cs_typed_addresses,
  139.          cs_delphi2_compatible,cs_tp_compatible,cs_static_keyword,
  140.          cs_strict_var_strings,cs_fp_emulation,
  141. {$ifdef SUPPORT_MMX}
  142.          cs_mmx,cs_mmx_saturation,
  143. {$endif SUPPORT_MMX}
  144.          cs_profile,
  145.          cs_link_dynamic,cs_link_static,cs_no_linking,cs_unit_to_lib,
  146.          cs_shared_lib,cs_load_objpas_unit);
  147.  
  148.        tcswitches = set of tcswitch;
  149.  
  150.        pcswitches = ^tcswitches;
  151.  
  152.        stringid = string[maxidlen];
  153.  
  154.        pdouble = ^double;
  155.  
  156.        pbyte = ^byte;
  157.  
  158.        plongint = ^longint;
  159.  
  160. {$ifdef i386}
  161.        tprocessors = (i386,i486,pentium,pentiumpro,pentium2);
  162. {$endif}
  163. {$ifdef m68k}
  164.        tprocessors = (MC68000,MC68020);
  165. {$endif}
  166.  
  167.  
  168. {$ifdef i386}
  169.        tof = (of_none,of_o,of_obj,of_masm,of_att,of_nasm,of_win32);
  170. {$endif}
  171. {$ifdef m68k}
  172.        { the support will start with the following formats :
  173.          of_o = amiga/atari/mac native object format
  174.          of_gas = gas styled motorola assembler
  175.          of_mot = motorola styled assembler
  176.          of_mit = MIT syntax (old styled gas)
  177.        }
  178.        tof = (of_none,of_o,of_gas,of_mot,of_mit);
  179. {$endif}
  180.  
  181.        tcompilerstate = record
  182.           switches : tcswitches;
  183.           exprlevel : byte;
  184.        end;
  185.  
  186.        { this type will be sent from the compiler to the IDE to make up a }
  187.        { status window                                                    }
  188.        tcompilestatus = record
  189.               { filename }
  190.               currentsource : string;
  191.  
  192.               { current line number }
  193.               currentline : longint;
  194.  
  195.               { will implement a percentage bar         }
  196.  
  197.               { the number of lines which are compiled  }
  198.               totalcompiledlines : longint;
  199.  
  200.               { Note:                                   }
  201.               { it's possible that totallines is zero,  }
  202.               { this means the compiler didn't know the }
  203.               { total lines                             }
  204.               totallines : longint;
  205.        end;
  206.  
  207.        { such a procedure is called from the compiler, }
  208.        { to put some informations to the ide etc.      }
  209.        { if the function returns true, the compiler    }
  210.        { stops                                         }
  211.        tcompilestatusproc = function(const status : tcompilestatus) : boolean;
  212.  
  213. {$ifdef i386}
  214.        ti386asmmode = (I386_ATT,I386_INTEL,I386_DIRECT);
  215.  
  216.     const
  217.        { the current mode which is in assembler blocks assumed }
  218.        aktasmmode : ti386asmmode = I386_DIRECT;
  219. {$endif}
  220.  
  221.     var
  222.        compilestatusproc : tcompilestatusproc;
  223.  
  224.        inputdir       : dirstr;
  225.        inputfile      : namestr;
  226.        inputextension : extstr;
  227.        { some flags for global compiler switches }
  228.        use_pipe,
  229.        do_build,do_make,writeasmfile,externasm,externlink : boolean;
  230.        assem_need_external_list,not_unit_proc : boolean;
  231.        { path for searching units, different paths can be seperated by ; }
  232.        exepath            : dirstr;  { Path to ppc }
  233.        unitsearchpath,
  234.        objectsearchpath,
  235.        includesearchpath,
  236.        librarysearchpath  : string;
  237.  
  238.        initswitches  : tcswitches;
  239.        { alignement of records }
  240.        initpackrecords : word;
  241.  
  242.        { current state state }
  243.        aktswitches    : Tcswitches;
  244.        aktpackrecords : word;
  245.        { this list contains the defines      }
  246.        { from the command line, this defines }
  247.        commandlinedefines : tlinkedlist;
  248.  
  249.        abslines : longint;         { number of lines which are compiled }
  250.        in_args : boolean;          { arguments must be checked especially }
  251.        parsing_para_level : longint; { parameter level, used to convert
  252.                                      proc calls to proc loads in firstcalln }
  253.        Must_be_valid : boolean;    { should the variable already have a value }
  254.  
  255. {$ifdef TP}
  256.        use_big      : boolean;
  257. {$ifndef dpmi}
  258.        symbolstream : temsstream;  { stream which is used to store some     }
  259.                                    { informtions to use not much DOS memory }
  260. {$else}
  261.        symbolstream: tmemorystream;
  262. {$endif}
  263.                                    { die Symbole abgelegt werden              }
  264. {$endif}
  265.        gendeffile  : boolean;      { true, when a DEF-file should be created }
  266.        genpm : boolean;            { true, when in the DEF-file WINDOWAPI should be placed }
  267.        description : string;       { description in the DEF-file }
  268.        deffile : text;             { Textfile for the DEF-file }
  269.  
  270.        opt_processors : tprocessors;
  271.        commandline_output_format : tof;
  272.        output_format : tof;
  273.  
  274.        { true, if C styled macros should be allowed  }
  275.        { boolean and not a set element, because it's }
  276.        { asked _very_ often                          }
  277.        support_macros : boolean;
  278.  
  279.        { true, if inline like in C++ should be supported }
  280.        support_inline : boolean;
  281.  
  282.        { to test for call with ESP as stack frame }
  283.        use_esp_stackframe : boolean;
  284.  
  285.        language : char;
  286.  
  287.        warnings : boolean;
  288.  
  289.        { to allow explicit executable filename }
  290. {       exename : string;}
  291.  
  292.        { use operators like in C (/=,*=, etc. }
  293.        c_like_operators : boolean;
  294.  
  295.        { contains the units which must be initilizied or linked }
  296.        usedunits : tlinkedlist;
  297.        dispose_asm_lists : boolean;
  298.  
  299.     function upper(const s : string) : string;
  300.     procedure uppervar(var s : string);
  301.     function tostr(i : longint) : string;
  302.     function tostr_with_plus(i : longint) : string;
  303.     procedure globalsinit;
  304.     function ibm2ascii(const s : string) : string;
  305.     function double2str(d : double) : string;
  306.     function comp2str(d : bestreal) : string;
  307.     procedure setstring(var p : pchar;const s : string);
  308.     function bstoslash(const s : string) : string;
  309.     function lowercase(const s : string) : string;
  310.  
  311.     function min(a,b : longint) : longint;
  312.     function max(a,b : longint) : longint;
  313.  
  314.     { sucht Datei mit Namen f in den in path angegebenen Verzeichnissen }
  315.     function  filetimestring( t : longint) : string;
  316.     function path_absolute(const s : string) : boolean;
  317.     Function FileExists ( Const F : String) : Boolean;
  318.     Function GetFileTime ( Var F : File) : Longint;
  319.     Function GetNamedFileTime ( Const F : String) : Longint;
  320.     Function FixPath(s:string):string;
  321.     function FixFileName(const s:string):string;
  322.     procedure AddPathToList(var list:string;s:string;first:boolean);
  323.     function search(const f : string;path : string;var b : boolean) : string;
  324.     function FindExe(bin:string;var found:boolean):string;
  325.  
  326. {$Ifdef EXTDEBUG}
  327.     const debugstop  : boolean = false;
  328. {$EndIf EXTDEBUG}
  329. {$ifdef debug}
  330.     { if the pointer don't point to the heap then write an error }
  331.     function assigned(p : pointer) : boolean;
  332. {$endif}
  333.     function ispowerof2(value : longint;var power : longint) : boolean;
  334.  
  335.     procedure valint(S : string;var V : longint;var code : word);
  336.  
  337.     { determines if s is a number }
  338.     function is_number(const s : string) : boolean;
  339.  
  340.     { token position }
  341.     function get_current_col : longint;
  342.  
  343.     const
  344.        lastlinepointer : longint = 0;
  345.        lasttokenpos : longint = 0;
  346.        { used in symtable.pas and options.pas }
  347.        use_gsym : boolean = false;
  348.        use_dbx    : boolean   = false;
  349.  
  350.     const
  351.     {$ifdef i386}
  352.        heapsize : longint = 2621440;    { 25600K default heap  }
  353.        stacksize : longint = 8192;      {     8K default stack }
  354.     {$endif}
  355.     {$ifdef m68k}
  356.        heapsize : longint =  131072 ;   {   128K default heap  }
  357.        stacksize : longint =  16384 ;   {    16K default stack }
  358.     {$endif m68k}
  359.        compile_level : word = 0;
  360.  
  361.   implementation
  362.  
  363.     uses
  364.       systems;
  365.  
  366.     function is_number(const s : string) : boolean;
  367.  
  368.       var
  369.          w : word;
  370.          l : longint;
  371.  
  372.       begin
  373.          valint(s,l,w);
  374.          is_number:=w=0;
  375.       end;
  376.  
  377.     function get_current_col : longint;
  378.       begin
  379.          if lastlinepointer<=lasttokenpos then
  380.            get_current_col:=lasttokenpos-lastlinepointer+1
  381.          else
  382.            get_current_col:=0;
  383.       end;
  384.  
  385.     procedure valint(S : string;var V : longint;var code : word);
  386. {$ifndef FPC}
  387.       var vs : longint;
  388.           c : byte;
  389.       begin
  390.         if s[1]='%' then
  391.           begin
  392.              vs:=0;
  393.              longint(v):=0;
  394.              for c:=2 to length(s) do
  395.                begin
  396.                   if s[c]='0' then
  397.                     vs:=vs*2
  398.                   else
  399.                   if s[c]='1' then
  400.                     vs:=vs*2+1
  401.                   else
  402.                     begin
  403.                       code:=c;
  404.                       exit;
  405.                     end;
  406.                end;
  407.              code:=0;
  408.              longint(v):=vs;
  409.           end
  410.         else
  411.          system.val(S,V,code);
  412.       end;
  413. {$else not FPC}
  414.       begin
  415.          system.val(S,V,code);
  416.       end;
  417. {$endif not FPC}
  418.  
  419.     function double2str(d : double) : string;
  420.  
  421.       var
  422.          hs : string;
  423.          p : byte;
  424.  
  425.       begin
  426.          str(d,hs);
  427. {$ifdef i386}
  428.          { replace space with + }
  429.          if (output_format in [of_att,of_o,of_win32]) then
  430.            begin
  431.               if hs[1]=' ' then
  432.                 hs[1]:='+';
  433.               double2str:='0d'+hs
  434.            end
  435.          else if (output_format in [of_obj,of_nasm]) then
  436.          { nasm expects a lowercase e }
  437.            begin
  438.               p:=pos('E',hs);
  439.               if p>0 then hs[p]:='e';
  440.               p:=pos('+',hs);
  441.               if p>0 then
  442.                 delete(hs,p,1);
  443.               double2str:=lowercase(hs);
  444. {$endif}
  445. {$ifdef m68k}
  446.          { replace space with + }
  447.          if (output_format=of_gas) then
  448.            begin
  449.               if hs[1]=' ' then
  450.                 hs[1]:='+';
  451.               double2str:='0d'+hs
  452. {$endif}
  453.            end
  454.          else
  455.            double2str:=hs;
  456.       end;
  457.  
  458.  
  459.     function comp2str(d : bestreal) : string;
  460.       type
  461.         pdouble = ^double;
  462.       var
  463. {$ifdef m68k}
  464.         c  : bestreal;
  465. {$else}
  466.         c  : comp;
  467. {$endif}
  468.         dd : pdouble;
  469.       begin
  470.          c:=d;{ this generates a warning but this is not important }
  471. {$ifndef TP}
  472. {$warning The following warning can be ignored}
  473. {$endif TP}
  474.          dd:=pdouble(@c); { this makes a bitwise copy of c into a double }
  475.          comp2str:=double2str(dd^);
  476.       end;
  477.  
  478.     function ispowerof2(value : longint;var power : longint) : boolean;
  479.  
  480.       var
  481.          hl : longint;
  482.          i : longint;
  483.  
  484.       begin
  485.          hl:=1;
  486.          ispowerof2:=true;
  487.          for i:=0 to 31 do
  488.            begin
  489.               if hl=value then
  490.                 begin
  491.                    power:=i;
  492.                    exit;
  493.                 end;
  494.               hl:=hl shl 1;
  495.            end;
  496.          ispowerof2:=false;
  497.       end;
  498.  
  499.     function lowercase(const s : string) : string;
  500.       var
  501.          i : longint;
  502.       begin
  503.         for i := 1 to length (s) do
  504.          lowercase[i]:=cobjects.lowercase(s[i]);
  505.         lowercase[0]:=s[0];
  506.       end;
  507.  
  508.     { used with the debugger option for the filename }
  509.     { because AS doesnt like '\'                     }
  510.     function bstoslash(const s : string) : string;
  511.       var
  512.          i : longint;
  513.       begin
  514.         for i:=1to length(s) do
  515.          if s[i]='\' then
  516.           bstoslash[i]:='/'
  517.          else
  518.           bstoslash[i]:=s[i];
  519.         bstoslash[0]:=s[0];
  520.       end;
  521.  
  522.   {$ifdef debug}
  523.  
  524.     function assigned(p : pointer) : boolean;
  525.  
  526.       var
  527.          lp : longint;
  528.  
  529.       begin
  530.   {$ifdef FPC}
  531.          lp:=longint(p);
  532.   {$else}
  533.     {$ifdef DPMI}
  534.          assigned:=(p<>nil);
  535.          exit;
  536.     {$else DPMI}
  537.          if p=nil then
  538.            lp:=0
  539.          else
  540.            lp:=longint(ptrrec(p).seg)*16+longint(ptrrec(p).ofs);
  541.          if (lp<>0) and
  542.             ((lp<longint(seg(heaporg^))*16+longint(ofs(heaporg^))) or
  543.             (lp>longint(seg(heapptr^))*16+longint(ofs(heapptr^)))) then
  544.            runerror(230);
  545.     {$endif DPMI}
  546.   {$endif FPC}
  547.          assigned:=lp<>0;
  548.       end;
  549.  
  550.   {$endif}
  551.  
  552.     function min(a,b : longint) : longint;
  553.  
  554.       begin
  555.          if a>b then
  556.            min:=b
  557.          else min:=a;
  558.       end;
  559.  
  560.     function max(a,b : longint) : longint;
  561.  
  562.       begin
  563.          if a<b then
  564.            max:=b
  565.          else max:=a;
  566.       end;
  567.  
  568.     function ibm2ascii(const s : string) : string;
  569.  
  570.       var
  571.          i : integer;
  572.          hs : string;
  573.          b : byte;
  574.  
  575.       begin
  576.          hs:='';
  577.          for i:=1 to length(s) do
  578.            if ((ord(s[i])>127) or (ord(s[i])<32)) or (s[i]='"') then
  579.              begin
  580.                 b:=ord(s[i]);
  581.                                 hs:=hs+'\'+tostr(b shr 6);
  582.                                 b:=b mod 64;
  583.                                 hs:=hs+tostr(b shr 3);
  584.                                 b:=b mod 8;
  585.                                 hs:=hs+tostr(b);
  586.                                 if (i<length(s)) and
  587.                                   (ord(s[i+1])>=48) and  (ord(s[i+1])<=57) then
  588.                                   hs:=hs+'","';
  589.                          end
  590.                    else if s[i]='\' then
  591.                          hs:=hs+'\\'
  592.                    else hs:=hs+s[i];
  593.                  ibm2ascii:=hs;
  594.           end;
  595.  
  596.     function upper(const s : string) : string;
  597.  
  598.       var
  599.          i : integer;
  600.          hs : string;
  601.  
  602.       begin
  603.          hs:='';
  604.          for i:=1 to length(s) do
  605.            hs:=hs+upcase(s[i]);
  606.          upper:=hs;
  607.       end;
  608.  
  609.     procedure uppervar(var s : string);
  610.  
  611.       var
  612.          i : integer;
  613.  
  614.       begin
  615.          for i:=1 to length(s) do
  616.            s[i]:=upcase(s[i]);
  617.       end;
  618.  
  619.    function tostr(i : longint) : string;
  620.  
  621.      var hs : string;
  622.  
  623.      begin
  624.         str(i,hs);
  625.         tostr:=hs;
  626.      end;
  627.  
  628.    function tostr_with_plus(i : longint) : string;
  629.  
  630.      var hs : string;
  631.  
  632.      begin
  633.         str(i,hs);
  634.         if i>=0 then
  635.                     tostr_with_plus:='+'+hs
  636.                   else
  637.                     tostr_with_plus:=hs;
  638.          end;
  639.  
  640.    procedure setstring(var p : pchar;const s : string);
  641.  
  642.      begin
  643. {$ifdef TP}
  644.              if use_big then
  645.                begin
  646.              p:=pchar(symbolstream.getsize);
  647.                   symbolstream.seek(longint(p));
  648.                   symbolstream.writestr(@s);
  649.           end
  650.         else
  651. {$endif TP}
  652.              p:=strpnew(s);
  653.      end;
  654.  
  655.  
  656.  {****************************************************************************
  657.                                File Handling
  658.  ****************************************************************************}
  659.  
  660.    function  filetimestring( t : longint) : string;
  661.  
  662.        Function L0(l:longint):string;
  663.        var
  664.          s : string;
  665.        begin
  666.          Str(l,s);
  667.          if l<10 then
  668.           s:='0'+s;
  669.          L0:=s;
  670.        end;
  671.  
  672.      var
  673.     {$ifndef linux}
  674.        DT : DateTime;
  675.      {$endif}
  676.        Year,Month,Day,Hour,Min,Sec : Word;
  677.  
  678.      begin
  679.      {$ifndef linux}
  680.        unpacktime(t,DT);
  681.        Year:=dT.year;month:=dt.month;day:=dt.day;
  682.        Hour:=dt.hour;min:=dt.min;sec:=dt.sec;
  683.      {$else}
  684.        EpochToLocal (t,year,month,day,hour,min,sec);
  685.      {$endif}
  686.        filetimestring:=L0(Year)+'/'+L0(Month)+'/'+L0(Day)+' '+L0(Hour)+':'+L0(min)+':'+L0(sec);
  687.      end;
  688.  
  689.    function path_absolute(const s : string) : boolean;
  690.  
  691.      begin
  692.         path_absolute:=false;
  693. {$ifdef linux}
  694.         if (length(s)>0) and (s[1]='/') then
  695.           path_absolute:=true;
  696. {$else not linux }
  697.   {$ifdef amiga}
  698.         if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or
  699.            (Pos(':',s) = length(s)) then
  700.              path_absolute:=true;
  701.   {$else}
  702.         if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or
  703.            ((length(s)>2) and (s[2]=':') and ((s[3]='\') or (s[3]='/'))) then
  704.           path_absolute:=true;
  705.   {$endif}
  706. {$endif linux }
  707.  
  708.      end;
  709.  
  710.     Function FileExists ( Const F : String) : Boolean;
  711.  
  712.       Var
  713.       {$ifdef linux}
  714.          Info : Stat;
  715.       {$else}
  716.          Info : SearchRec;
  717.       {$endif}
  718.  
  719.           begin
  720.       {$ifdef linux}
  721.            FileExists:=FStat(F,info);
  722.       {$else}
  723.            findfirst(F,anyfile,info);
  724.            FileExists:=doserror=0 ;
  725.       {$endif}
  726.           end;
  727.  
  728.     Function FixPath(s:string):string;
  729.       const
  730. {$ifndef linux}
  731.    {$ifdef amiga}
  732.         DirSep = '/';
  733.    {$else}
  734.         DirSep = '\';
  735.    {$endif}
  736. {$else}
  737.         DirSep = '/';
  738. {$endif}
  739.       var
  740.         i : longint;
  741.       begin
  742.         for i:=1to length(s) do
  743.          if s[i] in ['/','\'] then
  744.           s[i]:=DirSep;
  745.         if (length(s)>0) and (s[length(s)]<>DirSep) then
  746.          s:=s+DirSep;
  747.         if s='.'+DirSep then
  748.          s:='';
  749.         FixPath:=s;
  750.       end;
  751.  
  752.    function FixFileName(const s:string):string;
  753.      var
  754.        i      : longint;
  755.        NoPath : boolean;
  756.      begin
  757.        NoPath:=true;
  758.        for i:=length(s) downto 1 do
  759.         begin
  760.           case s[i] of
  761.       {$ifdef Linux}
  762.        '/','\' : begin
  763.                    FixFileName[i]:='/';
  764.                    NoPath:=false; {Skip lowercasing path: 'X11'<>'x11' }
  765.                  end;
  766.       'A'..'Z' : if NoPath then
  767.                   FixFileName[i]:=char(byte(s[i])+32)
  768.                  else
  769.                   FixFileName[i]:=s[i];
  770.       {$else}
  771.         {$ifdef amiga}
  772.          '/','\' : FixFileName[i]:='/';
  773.         'a'..'z' : FixFileName[i]:=char(byte(s[i])-32);
  774.         {$else}
  775.            '/' : FixFileName[i]:='\';
  776.       'a'..'z' : FixFileName[i]:=char(byte(s[i])-32);
  777.         {$endif amiga}
  778.       {$endif}
  779.           else
  780.            FixFileName[i]:=s[i];
  781.           end;
  782.         end;
  783.        FixFileName[0]:=s[0];
  784.      end;
  785.  
  786.    procedure AddPathToList(var list:string;s:string;first:boolean);
  787.       const
  788. {$ifndef linux}
  789.    {$ifdef amiga}
  790.         DirSep = '/';
  791.    {$else}
  792.         DirSep = '\';
  793.    {$endif}
  794. {$else}
  795.         DirSep = '/';
  796. {$endif}
  797.      var
  798.        LastAdd,
  799.        starti,i,j : longint;
  800.        Found    : boolean;
  801.        CurrentDir,
  802.        CurrPath,
  803.        AddList  : string;
  804.      begin
  805.        if s='' then
  806.         exit;
  807.      {Fix List}
  808.        if (length(list)>0) and (list[length(list)]<>';') then
  809.         begin
  810.           inc(byte(list[0]));
  811.           list[length(list)]:=';'
  812.         end;
  813.        GetDir(0,CurrentDir);
  814.        CurrentDir:=FixPath(CurrentDir);
  815.        AddList:='';
  816.        LastAdd:=1;
  817.        repeat
  818.          j:=Pos(';',s);
  819.          if j=0 then
  820.           j:=255;
  821.        {Get Pathname}
  822.          CurrPath:=FixPath(Copy(s,1,j-1));
  823.          if CurrPath='' then
  824.           CurrPath:='.'+DirSep+';'
  825.          else
  826.           begin
  827.             CurrPath:=FixPath(FExpand(CurrPath))+';';
  828.             if (Copy(CurrPath,1,length(CurrentDir))=CurrentDir) then
  829.              CurrPath:='.'+DirSep+Copy(CurrPath,length(CurrentDir)+1,255);
  830.           end;
  831.          Delete(s,1,j);
  832.        {Check if already in path}
  833.          found:=false;
  834.          i:=0;
  835.          starti:=1;
  836.          while (not found) and (i<length(list)) do
  837.           begin
  838.             inc(i);
  839.             if (list[i]=';') then
  840.              begin
  841.                found:=(CurrPath=Copy(List,starti,i-starti+1));
  842.                if Found then
  843.                 begin
  844.                   if First then
  845.                    Delete(List,Starti,i-starti+1); {The new entry is placed first}
  846.                 end
  847.                else
  848.                 starti:=i+1;
  849.              end;
  850.           end;
  851.          if First then
  852.           begin
  853.             Insert(CurrPath,List,LastAdd);
  854.             inc(LastAdd,Length(CurrPath));
  855.           end
  856.          else
  857.           if not Found then
  858.            List:=List+CurrPath
  859.        until (s='');
  860.      end;
  861.  
  862.    function search(const f : string;path : string;var b : boolean) : string;
  863.  
  864.       Var
  865.         singlepathstring : string;
  866.         i : longint;
  867.  
  868.      begin
  869.      {$ifdef linux}
  870.        for i:=1to length(path) do
  871.         if path[i]=':' then
  872.        path[i]:=';';
  873.      {$endif}
  874.        b:=false;
  875.        search:='';
  876.        repeat
  877.          i:=pos(';',path);
  878.          if i=0 then
  879.            i:=255;
  880.          singlepathstring:=FixPath(copy(path,1,i-1));
  881.          delete(path,1,i);
  882.          If FileExists (singlepathstring+f) then
  883.            begin
  884.              Search:=singlepathstring;
  885.              b:=true;
  886.              exit;
  887.            end;
  888.        until path='';
  889.      end;
  890.  
  891.    Function GetFileTime ( Var F : File) : Longint;
  892.  
  893.    Var
  894. {$ifdef linux}
  895.       Info : Stat;
  896. {$endif}
  897.       L : longint;
  898.  
  899.    begin
  900.      {$ifdef linux}
  901.      FStat (F,Info);
  902.      L:=Info.Mtime;
  903.      {$else}
  904.      GetFTime(f,l);
  905.      {$endif}
  906.      GetFileTime:=L;
  907.    end;
  908.  
  909.    Function GetNamedFileTime (Const F : String) : Longint;
  910.  
  911.    var
  912.      L : Longint;
  913.    {$ifndef linux}
  914.      info : SearchRec;
  915.    {$else}
  916.      info : stat;
  917.    {$endif}
  918.  
  919.    begin
  920.      l:=-1;
  921.      {$ifdef linux}
  922.      if FStat (F,Info) then L:=info.mtime;
  923.      {$else}
  924.      FindFirst (F,anyfile,info);
  925.      if DosError=0 then l:=info.time;
  926.      {$endif}
  927.      GetNamedFileTime:=l;
  928.    end;
  929.  
  930.  
  931.    function FindExe(bin:string;var found:boolean):string;
  932.    begin
  933.      bin:=FixFileName(bin)+source_info.exeext;
  934.      FindExe:=Search(bin,'.;'+exepath+';'+dos.getenv('PATH'),found)+bin;
  935.    end;
  936.  
  937.  
  938.  {****************************************************************************
  939.                                     Init
  940.  ****************************************************************************}
  941.  
  942.    procedure globalsinit;
  943.  
  944.      begin
  945.         { set global (for any file) compiler switches }
  946. {$ifdef i386}
  947.         opt_processors:=i386;
  948. {$endif}
  949. {$ifdef m68k}
  950.        opt_processors := MC68000;
  951. {$endif}
  952.         commandline_output_format:=of_o;
  953.         output_format:=of_o;
  954.         writeasmfile:=false;
  955.         externasm:=false;
  956.         externlink:=false;
  957.         warnings:=true;
  958.         do_build:=false;
  959.         do_make:=true;
  960.         language:='E';
  961.         gendeffile:=false;
  962.         genpm:=false;
  963.         description:='compiled by Free Pascal Compiler';
  964.  
  965.         { set the local switches informations }
  966.         initswitches:=[cs_check_unit_name,cs_extsyntax];
  967. {$ifdef m68k}
  968.         initswitches:=initswitches+[cs_fp_emulation];
  969. {$endif}
  970.         initpackrecords:=2;
  971.  
  972.         { statistic value }
  973.         abslines:=1;
  974. {$ifdef tp}
  975.         use_big:=false;
  976. {$endif tp}
  977.         { init container for files to link }
  978.         support_macros:=false;
  979.         support_inline:=false;
  980.         c_like_operators:=false;
  981.         in_args:=false;
  982.         must_be_valid:=true;
  983.         assem_need_external_list:=false;
  984.         not_unit_proc:=true;
  985.      end;
  986.  
  987. end.
  988. {
  989.   $Log: globals.pas,v $
  990.   Revision 1.6.2.7  1998/08/18 13:41:22  carl
  991.     + 128K default heap for m68k
  992.     + 16K heap for atari
  993.  
  994.   Revision 1.6.2.6  1998/08/13 13:32:24  carl
  995.     + Amiga path support
  996.  
  997.   Revision 1.6.2.5  1998/07/29 12:28:49  carl
  998.     * 64k heap for m68k targets
  999.  
  1000.   Revision 1.6.2.4  1998/07/21 12:09:20  carl
  1001.     * comp2str now works on m68k targets
  1002.  
  1003.   Revision 1.6.2.3  1998/04/08 11:38:44  peter
  1004.     * nasm patches, pierres symtable patch
  1005.  
  1006.   Revision 1.6.2.2  1998/04/07 21:59:16  peter
  1007.     * fixed fixpath, addpath
  1008.  
  1009.   Revision 1.6.2.1  1998/04/06 16:21:09  peter
  1010.     * carl and mine bugfixes from the mainbranch applied
  1011.  
  1012.   Revision 1.6  1998/03/30 21:03:59  florian
  1013.     * new version 0.99.5
  1014.     + cdecl id
  1015.  
  1016.   Revision 1.5  1998/03/30 15:53:00  florian
  1017.     * last changes before release:
  1018.        - gdb fixed
  1019.        - ratti386 warning removed (about unset function result)
  1020.  
  1021.   Revision 1.4  1998/03/29 10:49:27  florian
  1022.     * small problem with unit search path solved
  1023.  
  1024.   Revision 1.3  1998/03/28 23:09:56  florian
  1025.     * secondin bugfix (m68k and i386)
  1026.     * overflow checking bugfix (m68k and i386) -- pretty useless in
  1027.       secondadd, since everything is done using 32-bit
  1028.     * loading pointer to routines hopefully fixed (m68k)
  1029.     * flags problem with calls to RTL internal routines fixed (still strcmp
  1030.       to fix) (m68k)
  1031.     * #ELSE was still incorrect (didn't take care of the previous level)
  1032.     * problem with filenames in the command line solved
  1033.     * problem with mangledname solved
  1034.     * linking name problem solved (was case insensitive)
  1035.     * double id problem and potential crash solved
  1036.     * stop after first error
  1037.     * and=>test problem removed
  1038.     * correct read for all float types
  1039.     * 2 sigsegv fixes and a cosmetic fix for Internal Error
  1040.     * push/pop is now correct optimized (=> mov (%esp),reg)
  1041.  
  1042.   Revision 1.2  1998/03/26 11:18:30  florian
  1043.     - switch -Sa removed
  1044.     - support of a:=b:=0 removed
  1045.  
  1046.   Revision 1.1.1.1  1998/03/25 11:18:16  root
  1047.   * Restored version
  1048.  
  1049.   Revision 1.56  1998/03/22 12:43:31  florian
  1050.   *** empty log message ***
  1051.  
  1052.   Revision 1.55  1998/03/16 22:42:20  florian
  1053.     * some fixes of Peter applied:
  1054.       ofs problem, profiler support
  1055.  
  1056.  
  1057.   Revision 1.54  1998/03/16 08:49:14  michael
  1058.   * Anoither fix for Upper/lowercase paths.
  1059.  
  1060.   Revision 1.53  2036/02/07 09:29:32  florian
  1061.     * patch of Carl applied
  1062.  
  1063.   Revision 1.52  1998/03/10 23:48:36  florian
  1064.     * a couple of bug fixes to get the compiler with -OGaxz compiler, sadly
  1065.       enough, it doesn't run
  1066.  
  1067.   Revision 1.51  1998/03/10 01:17:19  peter
  1068.     * all files have the same header
  1069.     * messages are fully implemented, EXTDEBUG uses Comment()
  1070.     + AG... files for the Assembler generation
  1071.  
  1072.   Revision 1.50  1998/03/09 12:58:10  peter
  1073.     * FWait warning is only showed for Go32V2 and $E+
  1074.     * opcode tables moved to i386.pas/m68k.pas to reduce circular uses (and
  1075.       for m68k the same tables are removed)
  1076.     + $E for i386
  1077.  
  1078.   Revision 1.49  1998/03/05 22:43:46  florian
  1079.     * some win32 support stuff added
  1080.  
  1081.   Revision 1.48  1998/03/04 17:33:45  michael
  1082.   + Changed ifdef FPK to ifdef FPC
  1083.  
  1084.   Revision 1.47  1998/03/02 21:21:39  jonas
  1085.     + added support for uncertain optimizations
  1086.  
  1087.   Revision 1.46  1998/03/02 16:00:31  peter
  1088.     * -Ch works again
  1089.  
  1090.   Revision 1.45  1998/03/02 13:38:39  peter
  1091.     + importlib object
  1092.     * doesn't crash on a systemunit anymore
  1093.     * updated makefile and depend
  1094.  
  1095.   Revision 1.44  1998/03/02 01:48:36  peter
  1096.     * renamed target_DOS to target_GO32V1
  1097.     + new verbose system, merged old errors and verbose units into one new
  1098.       verbose.pas, so errors.pas is obsolete
  1099.  
  1100.   Revision 1.43  1998/02/21 03:33:16  carl
  1101.     + mit syntax support
  1102.  
  1103.   Revision 1.42  1998/02/17 21:20:49  peter
  1104.     + Script unit
  1105.     + __EXIT is called again to exit a program
  1106.     - target_info.link/assembler calls
  1107.     * linking works again for dos
  1108.     * optimized a few filehandling functions
  1109.     * fixed stabs generation for procedures
  1110.  
  1111.   Revision 1.41  1998/02/16 13:46:39  michael
  1112.   + Further integration of linker object:
  1113.     - all options pertaining to linking go directly to linker object
  1114.     - removed redundant variables/procedures, especially in OS_TARG...
  1115.  
  1116.   Revision 1.40  1998/02/16 12:51:30  michael
  1117.   + Implemented linker object
  1118.  
  1119.   Revision 1.39  1998/02/14 01:45:21  peter
  1120.     * more fixes
  1121.     - pmode target is removed
  1122.     - search_as_ld is removed, this is done in the link.pas/assemble.pas
  1123.     + findexe() to search for an executable (linker,assembler,binder)
  1124.  
  1125.   Revision 1.38  1998/02/13 10:35:02  daniel
  1126.   * Made Motorola version compilable.
  1127.   * Fixed optimizer
  1128.  
  1129.   Revision 1.37  1998/02/12 11:50:06  daniel
  1130.   Yes! Finally! After three retries, my patch!
  1131.  
  1132.   Changes:
  1133.  
  1134.   Complete rewrite of psub.pas.
  1135.   Added support for DLL's.
  1136.   Compiler requires less memory.
  1137.   Platform units for each platform.
  1138.  
  1139.   Revision 1.36  1998/02/08 01:59:33  peter
  1140.     + option -P to allow the use of pipe for assembly output
  1141.  
  1142.   Revision 1.35  1998/02/07 09:39:22  florian
  1143.     * correct handling of in_main
  1144.     + $D,$T,$X,$V like tp
  1145.  
  1146.   Revision 1.34  1998/02/06 09:11:19  peter
  1147.     * added source_info.exeext and of_none for output_format
  1148.  
  1149.   Revision 1.33  1998/02/05 22:27:05  florian
  1150.     * small problems fixed: remake3 should now work
  1151.  
  1152.   Revision 1.32  1998/02/02 23:41:01  florian
  1153.     * data is now dword aligned per default else the stack ajustements are useless
  1154.  
  1155.   Revision 1.31  1998/02/02 00:55:31  peter
  1156.     * defdatei -> deffile and some german comments to english
  1157.     * search() accepts : as seperater under linux
  1158.     * search for ppc.cfg doesn't open a file (and let it open)
  1159.     * reorganize the reading of parameters/file a bit
  1160.     * all the PPC_ environments are now for all platforms
  1161.  
  1162.   Revision 1.30  1998/01/28 13:48:38  michael
  1163.   + Initial implementation for making libs from within FPC. Not tested, as compiler does not run
  1164.  
  1165.   Revision 1.29  1998/01/26 18:51:16  peter
  1166.     * ForceSlash() changed to FixPath() which also removes a trailing './'
  1167.  
  1168.   Revision 1.28  1998/01/25 18:45:42  peter
  1169.     + Search for as and ld at startup
  1170.     + source_info works the same as target_info
  1171.     + externlink allows only external linking
  1172.  
  1173.   Revision 1.27  1998/01/23 22:19:19  michael
  1174.   + Implemented setting of dynamic linker name (linux only).
  1175.     Declared Make_library
  1176.     -Fd switch sets linker (linux only)
  1177.   * Reinstated -E option of Pierre
  1178.  
  1179.   Revision 1.26  1998/01/23 17:55:07  michael
  1180.   + Moved linking stage to it's own unit (link.pas)
  1181.     Incorporated Pierres changes, but removed -E switch
  1182.     switch for not linking is now -Cn instead of -E
  1183.  
  1184.   Revision 1.25  1998/01/23 17:12:12  pierre
  1185.     * added some improvements for as and ld :
  1186.       - doserror and dosexitcode treated separately
  1187.       - PATH searched if doserror=2
  1188.     + start of long and ansi string (far from complete)
  1189.       in conditionnal UseLongString and UseAnsiString
  1190.     * options.pas cleaned (some variables shifted to globals)gl
  1191.  
  1192.   Revision 1.24  1998/01/23 08:54:23  florian
  1193.   *** empty log message ***
  1194.  
  1195.   Revision 1.23  1998/01/22 14:47:10  michael
  1196.   + Reinstated linker options as -k option. How did they dissapear ?
  1197.  
  1198.   Revision 1.22  1998/01/20 00:21:41  peter
  1199.     * under some circumstanes a path was expanded wrong
  1200.  
  1201.   Revision 1.21  1998/01/19 16:18:42  peter
  1202.   * AddPathtoList supports now ';' seperate paths and optimizes pathnames
  1203.  
  1204.   Revision 1.20  1998/01/17 01:57:33  michael
  1205.   + Start of shared library support. First working version.
  1206.  
  1207.   Revision 1.19  1998/01/16 18:03:14  florian
  1208.     * small bug fixes, some stuff of delphi styled constructores added
  1209.  
  1210.   Revision 1.18  1998/01/16 12:52:08  michael
  1211.   + Path treatment and file searching should now be more or less in their
  1212.     definite form:
  1213.     - Using now modified AddPathToList everywhere.
  1214.     - File Searching mechanism is uniform for all files.
  1215.     - Include path is working now !!
  1216.     All fixes by Peter Vreman. Tested with remake3 target.
  1217.  
  1218.   Revision 1.17  1998/01/16 00:00:54  michael
  1219.   + Better and more modular searching and loading of units.
  1220.     - searching in tmodule.search_unit.
  1221.     - initial Loading in tmpodule.load_ppu.
  1222.     - tmodule.init now calls search_unit.
  1223.   * Case sensitivity problem of unix hopefully solved now forever.
  1224.     (All from Peter Vreman, checked with remake3)
  1225.  
  1226.   Revision 1.16  1998/01/15 13:01:45  michael
  1227.   + Some more changes to ease file handling (From Peter Vreman)
  1228.  
  1229.   Revision 1.15  1998/01/13 23:11:10  florian
  1230.     + class methods
  1231.  
  1232.   Revision 1.14  1998/01/13 17:10:49  michael
  1233.   + Implemented
  1234.     GetFileTime      (get opend file time)
  1235.     GetNamedFileTime (get file time starting from file name)
  1236.     FileExist        (File exists: True)
  1237.   * Changed Time2string (or so) To work also with linux times.
  1238.     Times returned are now linux times under linux, not DateTimes
  1239.  
  1240.   Revision 1.13  1998/01/11 04:15:00  carl
  1241.   + correct floating point support for m68k
  1242.  
  1243.   Revision 1.12  1998/01/09 18:01:15  florian
  1244.     * VIRTUAL isn't anymore a common keyword
  1245.     + DYNAMIC is equal to VIRTUAL
  1246.  
  1247.   Revision 1.11  1998/01/09 13:39:54  florian
  1248.     * public, protected and private aren't anymore key words
  1249.     + published is equal to public
  1250.  
  1251.   Revision 1.10  1998/01/07 00:16:51  michael
  1252.   Restored released version (plus fixes) as current
  1253.  
  1254.   Revision 1.8  1997/12/14 22:43:18  florian
  1255.     + command line switch -Xs for DOS (passes -s to the linker to strip symbols from
  1256.       executable)
  1257.     * some changes of Carl-Eric implemented
  1258.  
  1259.   Revision 1.7  1997/12/13 18:59:45  florian
  1260.   + I/O streams are now also declared as external, if neccessary
  1261.   * -Aobj generates now a correct obj file via nasm
  1262.  
  1263.   Revision 1.6  1997/12/12 13:28:25  florian
  1264.   + version 0.99.0
  1265.   * all WASM options changed into MASM
  1266.   + -O2 for Pentium II optimizations
  1267.  
  1268.   Revision 1.5  1997/12/09 13:38:41  carl
  1269.   - removed some ifdef cpu
  1270.  
  1271.   Revision 1.4  1997/11/28 18:14:33  pierre
  1272.    working version with several bug fixes
  1273.  
  1274.   Revision 1.3  1997/11/28 08:46:46  florian
  1275.   Small changes
  1276.  
  1277.   Revision 1.2  1997/11/27 17:51:03  carl
  1278.   + added aktasmmode variable from rasm386.pas
  1279.  
  1280.   Revision 1.1.1.1  1997/11/27 08:32:56  michael
  1281.   FPC Compiler CVS start
  1282.  
  1283.  
  1284.   Pre-CVS log:
  1285.  
  1286.   CEC   Carl-Eric Codere
  1287.   FK    Florian Klaempfl
  1288.   PM    Pierre Muller
  1289.   +     feature added
  1290.   -     removed
  1291.   *     bug fixed or changed
  1292.  
  1293.   History:
  1294.       6th september 1997:
  1295.         + Added support for Emulation of Floating point instructions
  1296.               (Motorola only) (CEC)
  1297.       3 octboer 1997:
  1298.         + Works for both intel and motorola target (CEC).
  1299.       4 october 1997:
  1300.         + changed processor type to motorola (in ifdef m68k)
  1301.           and object output type. (check ifdef to find all
  1302.           changes).
  1303.       15th october 1997:
  1304.          + added cs_static_keyword switch to allow static keyword in objects (PM)
  1305.  
  1306. }
  1307.