fpc/compiler/scandir.inc

{
    $Id$
    Copyright (c) 1998-2000 by Peter Vreman

    This unit implements directive parsing for the scanner

    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.

 ****************************************************************************
}
const
   directivelen=15;
type
   directivestr=string[directivelen];
   tdirectivetoken=(
     _DIR_NONE,
     _DIR_ALIGN,_DIR_APPTYPE,_DIR_ASMMODE,_DIR_ASSERTIONS,
     _DIR_BOOLEVAL,
     _DIR_D,_DIR_DEBUGINFO,_DIR_DEFINE,_DIR_DESCRIPTION,
     _DIR_ELSE,_DIR_ENDIF,_DIR_ERROR,_DIR_EXTENDEDSYNTAX,
     _DIR_FATAL,
     _DIR_GOTO,
     _DIR_HINT,_DIR_HINTS,
     _DIR_I,_DIR_I386_ATT,_DIR_I386_DIRECT,_DIR_I386_INTEL,_DIR_IOCHECKS,
       _DIR_IF,_DIR_IFDEF,_DIR_IFNDEF,_DIR_IFOPT,_DIR_INCLUDE,_DIR_INCLUDEPATH,
       _DIR_INFO,_DIR_INLINE,
     _DIR_L,_DIR_LIBRARYPATH,_DIR_LINK,_DIR_LINKLIB,_DIR_LOCALSYMBOLS,
       _DIR_LONGSTRINGS,
     _DIR_M,_DIR_MACRO,_DIR_MAXFPUREGISTERS,_DIR_MEMORY,_DIR_MESSAGE,_DIR_MINENUMSIZE,_DIR_MMX,_DIR_MODE,
     _DIR_NOTE,_DIR_NOTES,
     _DIR_OBJECTPATH,_DIR_OPENSTRINGS,_DIR_OUTPUT_FORMAT,_DIR_OVERFLOWCHECKS,
     _DIR_PACKENUM,_DIR_PACKRECORDS,
     {$IFDEF Testvarsets}
      _DIR_PACKSET,
     {$ENDIF}
     _DIR_R,_DIR_RANGECHECKS,_DIR_REFERENCEINFO,
     _DIR_SATURATION,_DIR_SMARTLINK,_DIR_STACKFRAMES,_DIR_STATIC,_DIR_STOP,
     _DIR_TYPEDADDRESS,_DIR_TYPEINFO,
     _DIR_UNDEF,_DIR_UNITPATH,
     _DIR_VARSTRINGCHECKS,_DIR_VERSION,
     _DIR_WAIT,_DIR_WARNING,_DIR_WARNINGS,
     _DIR_Z1,_DIR_Z2,_DIR_Z4
     );
const
   firstdirective=_DIR_NONE;
   lastdirective=_DIR_Z4;
   directive:array[tdirectivetoken] of directivestr=(
     {12345678901234567890 (To determine longest string.)}
     '',
     'ALIGN',
     'APPTYPE',
     'ASMMODE',
     'ASSERTIONS',
     'BOOLEVAL',
     'D',
     'DEBUGINFO',
     'DEFINE',
     'DESCRIPTION',
     'ELSE',
     'ENDIF',
     'ERROR',
     'EXTENDEDSYNTAX',
     'FATAL',
     'GOTO',
     'HINT',
     'HINTS',
     'I',
     {12345678901234567890 (To determine longest string.)}
     'I386_ATT',
     'I386_DIRECT',
     'I386_INTEL',
     'IOCHECKS',
     'IF',
     'IFDEF',
     'IFNDEF',
     'IFOPT',
     'INCLUDE',
     'INCLUDEPATH',
     'INFO',
     'INLINE',
     'L',
     'LIBRARYPATH',
     'LINK',
     'LINKLIB',
     'LOCALSYMBOLS',
     'LONGSTRINGS',
     'M',
     {12345678901234567890 (To determine longest string.)}
     'MACRO',
     'MAXFPUREGISTERS',
     'MEMORY',
     'MESSAGE',
     'MINENUMSIZE',
     'MMX',
     'MODE',
     'NOTE',
     'NOTES',
     'OBJECTPATH',
     'OPENSTRINGS',
     'OUTPUT_FORMAT',
     'OVERFLOWCHECKS',
     'PACKENUM',
     'PACKRECORDS',
     {$IFDEF testvarsets}
     'PACKSET',
     {$ENDIF}
     'R',
     'RANGECHECKS',
     'REFERENCEINFO',
     'SATURATION',
     'SMARTLINK',
     {12345678901234567890 (To determine longest string.)}
     'STACKFRAMES',
     'STATIC',
     'STOP',
     'TYPEDADDRESS',
     'TYPEINFO',
     'UNDEF',
     'UNITPATH',
     'VARSTRINGCHECKS',
     'VERSION',
     'WAIT',
     'WARNING',
     'WARNINGS',
     'Z1',
     'Z2',
     'Z4'
     );



    function Get_Directive(const hs:string):tdirectivetoken;
      var
        i : tdirectivetoken;
      begin
        for i:=firstdirective to lastdirective do
         if directive[i]=hs then
          begin
            Get_Directive:=i;
            exit;
          end;
        Get_Directive:=_DIR_NONE;
     end;


  {-------------------------------------------
           IF Conditional Handling
  -------------------------------------------}

    var
      preprocpat    : string;
      preproc_token : ttoken;

    procedure preproc_consume(t : ttoken);
      begin
        if t<>preproc_token then
         Message(scan_e_preproc_syntax_error);
        preproc_token:=current_scanner^.readpreproc;
      end;

    function read_expr : string;forward;

    function read_factor : string;
      var
         hs : string;
         mac : pmacrosym;
         len : byte;
      begin
         if preproc_token=_ID then
           begin
              if preprocpat='NOT' then
                begin
                   preproc_consume(_ID);
                   hs:=read_expr;
                   if hs='0' then
                     read_factor:='1'
                   else
                     read_factor:='0';
                end
              else
                begin
                   mac:=pmacrosym(macros^.search(hs));
                   hs:=preprocpat;
                   preproc_consume(_ID);
                   if assigned(mac) then
                     begin
                        if mac^.defined and assigned(mac^.buftext) then
                          begin
                             if mac^.buflen>255 then
                               begin
                                  len:=255;
                                  Message(scan_w_macro_cut_after_255_chars);
                               end
                             else
                               len:=mac^.buflen;
                             {$ifndef TP}
                               {$ifopt H+}
                                 setlength(hs,len);
                               {$else}
                                 hs[0]:=char(len);
                               {$endif}
                             {$else}
                               hs[0]:=char(len);
                             {$endif}
                             move(mac^.buftext^,hs[1],len);
                          end
                        else
                          read_factor:='';
                     end
                   else
                     read_factor:=hs;
                end
           end
         else if preproc_token=_LKLAMMER then
           begin
              preproc_consume(_LKLAMMER);
              read_factor:=read_expr;
              preproc_consume(_RKLAMMER);
           end
         else
           Message(scan_e_error_in_preproc_expr);
      end;


    function read_term : string;
      var
         hs1,hs2 : string;
      begin
         hs1:=read_factor;
         while true do
           begin
              if (preproc_token=_ID) then
                begin
                   if preprocpat='AND' then
                     begin
                        preproc_consume(_ID);
                        hs2:=read_factor;
                        if (hs1<>'0') and (hs2<>'0') then
                          hs1:='1';
                     end
                   else
                     break;
                end
              else
                break;
           end;
         read_term:=hs1;
      end;


    function read_simple_expr : string;
      var
         hs1,hs2 : string;
      begin
         hs1:=read_term;
         while true do
           begin
              if (preproc_token=_ID) then
                begin
                   if preprocpat='OR' then
                     begin
                        preproc_consume(_ID);
                        hs2:=read_term;
                        if (hs1<>'0') or (hs2<>'0') then
                          hs1:='1';
                     end
                   else
                     break;
                end
              else
                break;
           end;
         read_simple_expr:=hs1;
      end;


    function read_expr : string;
      var
         hs1,hs2 : string;
         b : boolean;
         t : ttoken;
         w : integer;
         l1,l2 : longint;
      begin
         hs1:=read_simple_expr;
         t:=preproc_token;
         if not(t in [_EQUAL,_UNEQUAL,_LT,_GT,_LTE,_GTE]) then
           begin
              read_expr:=hs1;
              exit;
           end;
         preproc_consume(t);
         hs2:=read_simple_expr;
         if is_number(hs1) and is_number(hs2) then
           begin
              valint(hs1,l1,w);
              valint(hs2,l2,w);
              case t of
                 _EQUAL : b:=l1=l2;
               _UNEQUAL : b:=l1<>l2;
                    _LT : b:=l1<l2;
                    _GT : b:=l1>l2;
                   _GTE : b:=l1>=l2;
                   _LTE : b:=l1<=l2;
              end;
           end
         else
           begin
              case t of
                 _EQUAL : b:=hs1=hs2;
               _UNEQUAL : b:=hs1<>hs2;
                    _LT : b:=hs1<hs2;
                    _GT : b:=hs1>hs2;
                   _GTE : b:=hs1>=hs2;
                   _LTE : b:=hs1<=hs2;
              end;
           end;
         if b then
           read_expr:='1'
         else
           read_expr:='0';
     end;

  {-------------------------------------------
                Directives
  -------------------------------------------}

    function is_conditional(t:tdirectivetoken):boolean;
      begin
        is_conditional:=(t in [_DIR_ENDIF,_DIR_IFDEF,_DIR_IFNDEF,_DIR_IFOPT,_DIR_IF,_DIR_ELSE]);
      end;


    procedure dir_conditional(t:tdirectivetoken);
      var
        hs    : string;
        mac   : pmacrosym;
        found : boolean;
        state : char;
        oldaktfilepos : tfileposinfo;
      begin
        oldaktfilepos:=aktfilepos;
        while true do
         begin
           current_scanner^.gettokenpos;
           case t of
   _DIR_ENDIF : begin
                  current_scanner^.poppreprocstack;
                end;
    _DIR_ELSE : begin
                  current_scanner^.elsepreprocstack;
                end;
   _DIR_IFDEF : begin
                  current_scanner^.skipspace;
                  hs:=current_scanner^.readid;
                  mac:=pmacrosym(macros^.search(hs));
                  if assigned(mac) then
                    mac^.is_used:=true;
                  current_scanner^.addpreprocstack(pp_ifdef,assigned(mac) and mac^.defined,hs,scan_c_ifdef_found);
                end;
   _DIR_IFOPT : begin
                  current_scanner^.skipspace;
                  hs:=current_scanner^.readid;
                  if (length(hs)>1) then
                   Message(scan_w_illegal_switch)
                  else
                   begin
                     state:=current_scanner^.ReadState;
                     if state in ['-','+'] then
                      found:=CheckSwitch(hs[1],state);
                   end;
                  current_scanner^.addpreprocstack(pp_ifopt,found,hs,scan_c_ifopt_found);
                end;
      _DIR_IF : begin
                  current_scanner^.skipspace;
                  { start preproc expression scanner }
                  preproc_token:=current_scanner^.readpreproc;
                  hs:=read_expr;
                  current_scanner^.addpreprocstack(pp_if,hs<>'0',hs,scan_c_if_found);
                end;
  _DIR_IFNDEF : begin
                  current_scanner^.skipspace;
                  hs:=current_scanner^.readid;
                  mac:=pmacrosym(macros^.search(hs));
                  if assigned(mac) then
                    mac^.is_used:=true;
                  current_scanner^.addpreprocstack(pp_ifndef,not(assigned(mac) and mac^.defined),hs,scan_c_ifndef_found);
                end;
           end;
         { accept the text ? }
           if (current_scanner^.preprocstack=nil) or current_scanner^.preprocstack^.accept then
            break
           else
            begin
              current_scanner^.gettokenpos;
              Message(scan_c_skipping_until);
              repeat
                current_scanner^.skipuntildirective;
                t:=Get_Directive(current_scanner^.readid);
              until is_conditional(t);
              current_scanner^.gettokenpos;
              Message1(scan_d_handling_switch,'$'+directive[t]);
            end;
         end;
        aktfilepos:=oldaktfilepos;
      end;


    procedure dir_define(t:tdirectivetoken);
      var
        hs  : string;
        bracketcount : longint;
        mac : pmacrosym;
        macropos : longint;
        macrobuffer : pmacrobuffer;
      begin
        current_scanner^.skipspace;
        hs:=current_scanner^.readid;
        mac:=pmacrosym(macros^.search(hs));
        if not assigned(mac) then
          begin
            mac:=new(pmacrosym,init(hs));
            mac^.defined:=true;
            Message1(parser_m_macro_defined,mac^.name);
            macros^.insert(mac);
          end
        else
          begin
            Message1(parser_m_macro_defined,mac^.name);
            mac^.defined:=true;
          { delete old definition }
            if assigned(mac^.buftext) then
             begin
               freemem(mac^.buftext,mac^.buflen);
               mac^.buftext:=nil;
             end;
          end;
        mac^.is_used:=true;
        if (cs_support_macro in aktmoduleswitches) then
          begin
          { key words are never substituted }
             if is_keyword(hs) then
              Message(scan_e_keyword_cant_be_a_macro);
           { !!!!!! handle macro params, need we this? }
             current_scanner^.skipspace;
           { may be a macro? }
             if c=':' then
               begin
                  current_scanner^.readchar;
                  if c='=' then
                    begin
                       new(macrobuffer);
                       macropos:=0;
                       { parse macro, brackets are counted so it's possible
                         to have a $ifdef etc. in the macro }
                       bracketcount:=0;
                       repeat
                         current_scanner^.readchar;
                         case c of
                           '}' :
                             if (bracketcount=0) then
                              break
                             else
                              dec(bracketcount);
                           '{' :
                             inc(bracketcount);
                           #26 :
                             current_scanner^.end_of_file;
                         end;
                         macrobuffer^[macropos]:=c;
                         inc(macropos);
                         if macropos>maxmacrolen then
                          Message(scan_f_macro_buffer_overflow);
                       until false;
                       { free buffer of macro ?}
                       if assigned(mac^.buftext) then
                         freemem(mac^.buftext,mac^.buflen);
                       { get new mem }
                       getmem(mac^.buftext,macropos);
                       mac^.buflen:=macropos;
                       { copy the text }
                       move(macrobuffer^,mac^.buftext^,macropos);
                       dispose(macrobuffer);
                    end;
               end;
          end
        else
          begin
           { check if there is an assignment, then we need to give a
             warning }
             current_scanner^.skipspace;
             if c=':' then
              begin
                current_scanner^.readchar;
                if c='=' then
                  Comment(V_Warning,'Marco support has been turned off');
              end;
          end;
      end;


    procedure dir_undef(t:tdirectivetoken);
      var
        hs  : string;
        mac : pmacrosym;
      begin
        current_scanner^.skipspace;
        hs:=current_scanner^.readid;
        mac:=pmacrosym(macros^.search(hs));
        if not assigned(mac) then
          begin
             mac:=new(pmacrosym,init(hs));
             Message1(parser_m_macro_undefined,mac^.name);
             mac^.defined:=false;
             macros^.insert(mac);
          end
        else
          begin
             Message1(parser_m_macro_undefined,mac^.name);
             mac^.defined:=false;
             { delete old definition }
             if assigned(mac^.buftext) then
               begin
                  freemem(mac^.buftext,mac^.buflen);
                  mac^.buftext:=nil;
               end;
          end;
        mac^.is_used:=true;
      end;


    procedure dir_message(t:tdirectivetoken);
      var
        w   : longint;
      begin
        case t of
       _DIR_STOP,
      _DIR_FATAL : w:=scan_f_user_defined;
      _DIR_ERROR : w:=scan_e_user_defined;
    _DIR_WARNING : w:=scan_w_user_defined;
       _DIR_HINT : w:=scan_h_user_defined;
       _DIR_NOTE : w:=scan_n_user_defined;
    _DIR_MESSAGE,
       _DIR_INFO : w:=scan_i_user_defined;
        end;
        current_scanner^.skipspace;
        Message1(w,current_scanner^.readcomment);
      end;


    procedure dir_moduleswitch(t:tdirectivetoken);
      var
        sw : tmoduleswitch;
        state : char;
      begin
        sw:=cs_modulenone;
        case t of
          _DIR_GOTO      : sw:=cs_support_goto;
          _DIR_MACRO     : sw:=cs_support_macro;
          _DIR_INLINE    : sw:=cs_support_inline;
          _DIR_SMARTLINK : sw:=cs_create_smart;
          _DIR_STATIC    : sw:=cs_static_keyword;
        end;
        state:=current_scanner^.readstate;
        if (sw<>cs_modulenone) and (state in ['-','+']) then
         begin
           if state='-' then
            aktmoduleswitches:=aktmoduleswitches-[sw]
           else
            aktmoduleswitches:=aktmoduleswitches+[sw];
         end;
      end;


    procedure dir_localswitch(t:tdirectivetoken);
      var
        sw : tlocalswitch;
        state : char;
      begin
        sw:=cs_localnone;
{$ifdef SUPPORT_MMX}
        case t of
          _DIR_MMX : sw:=cs_mmx;
          _DIR_SATURATION : sw:=cs_mmx_saturation;
        end;
{$endif}
        state:=current_scanner^.readstate;
        if (sw<>cs_localnone) and (state in ['-','+']) then
         begin
           if not localswitcheschanged then
             nextaktlocalswitches:=aktlocalswitches;
           if state='-' then
            nextaktlocalswitches:=nextaktlocalswitches-[sw]
           else
            nextaktlocalswitches:=nextaktlocalswitches+[sw];
           localswitcheschanged:=true;
         end;
      end;


    procedure dir_include(t:tdirectivetoken);
      var
        hs    : string;
        path  : dirstr;
        name  : namestr;
        ext   : extstr;
        hp    : pinputfile;
        i     : longint;
        found : boolean;
      begin
        current_scanner^.skipspace;
        hs:=current_scanner^.readcomment;
        i:=length(hs);
        while (i>0) and (hs[i]=' ') do
         dec(i);
        Delete(hs,i+1,length(hs)-i);
        if hs='' then
         exit;
        if (hs[1]='%') then
         begin
         { case insensitive }
           hs:=upper(hs);
         { remove %'s }
           Delete(hs,1,1);
           if hs[length(hs)]='%' then
            Delete(hs,length(hs),1);
         { save old }
           path:=hs;
         { first check for internal macros }
           if hs='TIME' then
            hs:=gettimestr
           else
            if hs='DATE' then
             hs:=getdatestr
           else
            if hs='FILE' then
             hs:=current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex)
           else
            if hs='LINE' then
             hs:=tostr(aktfilepos.line)
           else
            if hs='FPCVERSION' then
             hs:=version_string
           else
            if hs='FPCTARGET' then
             hs:=target_cpu_string
           else
             hs:=getenv(hs);
           if hs='' then
            Message1(scan_w_include_env_not_found,path);
           { make it a stringconst }
           hs:=''''+hs+'''';
           current_scanner^.insertmacro(path,@hs[1],length(hs));
         end
        else
         begin
           hs:=FixFileName(hs);
           fsplit(hs,path,name,ext);
         { look for the include file
            1. specified path,path of current inputfile,current dir
            2. local includepath
            3. global includepath }
           found:=false;
           if path<>'' then
             path:=path+';';
           path:=FindFile(name+ext,path+current_scanner^.inputfile^.path^+';.'+DirSep,found);
           if (not found) then
            path:=current_module^.localincludesearchpath.FindFile(name+ext,found);
           if (not found) then
            path:=includesearchpath.FindFile(name+ext,found);
         { shutdown current file }
           current_scanner^.tempcloseinputfile;
         { load new file }
           hp:=do_openinputfile(path+name+ext);
           current_scanner^.addfile(hp);
           if not current_scanner^.openinputfile then
            Message1(scan_f_cannot_open_includefile,hs);
           Message1(scan_t_start_include_file,current_scanner^.inputfile^.path^+current_scanner^.inputfile^.name^);
           current_scanner^.reload;
         { process first read char }
           case c of
            #26 : current_scanner^.reload;
            #10,
            #13 : current_scanner^.linebreak;
           end;
         { register for refs }
           current_module^.sourcefiles^.register_file(hp);
         end;
      end;


    procedure dir_description(t:tdirectivetoken);
      begin
        if not (target_info.target in [target_i386_os2,target_i386_win32,target_i386_netware]) then
          Message(scan_w_decription_not_support);
        { change description global var in all cases }
        { it not used but in win32, os2 and netware }
        current_scanner^.skipspace;
        description:=current_scanner^.readcomment;
      end;


    procedure dir_version(t:tdirectivetoken);
      var
        major, minor, revision : longint;
        error : integer;
      begin
        if not (target_info.target in [target_i386_os2,target_i386_win32,target_i386_netware]) then  // AD
          begin
            Message(scan_n_version_not_support);
            exit;
          end;
        if (compile_level<>1) then
          Message(scan_n_only_exe_version)
        else
          begin
            { change description global var in all cases }
            { it not used but in win32, os2 and netware }
            current_scanner^.skipspace;
            { we should only accept Major.Minor format for win32 and os2 }
            current_scanner^.readnumber;
            major:=0;
            minor:=0;
            revision:=0;
            valint(pattern,major,error);
            if error<>0 then
              begin
                Message1(scan_w_wrong_version_ignored,pattern);
                exit;
              end;
            if c='.' then
              begin
                current_scanner^.readchar;
                current_scanner^.readnumber;
                valint(pattern,minor,error);
                if error<>0 then
                  begin
                    Message1(scan_w_wrong_version_ignored,tostr(major)+'.'+pattern);
                    exit;
                  end;
                if (c='.') and
                   (target_info.target = target_i386_netware) then  // AD
                  begin
                     current_scanner^.readchar;
                     current_scanner^.readnumber;
                     valint(pattern,revision,error);
                     if error<>0 then
                       begin
                          Message1(scan_w_wrong_version_ignored,tostr(revision)+'.'+pattern);
                          exit;
                       end;
                     dllmajor:=major;
                     dllminor:=minor;
                     dllrevision:=revision;
                     dllversion:=tostr(major)+','+tostr(minor)+','+tostr(revision);
                  end 
                else
                  begin                
                     dllmajor:=major;
                     dllminor:=minor;
                     dllversion:=tostr(major)+'.'+tostr(minor);
                  end; 
              end
            else
              dllversion:=tostr(major);
          end;
      end;


    procedure dir_linkobject(t:tdirectivetoken);
      var
        s : string;
      begin
        current_scanner^.skipspace;
        s:=AddExtension(FixFileName(current_scanner^.readcomment),target_info.objext);
      {$IFDEF NEWST}
        current_module^.linkotherofiles.
         insert(new(Plinkitem,init(s,link_allways)));
      {$ELSE}
        current_module^.linkotherofiles.
         insert(s,link_allways);
      {$ENDIF NEWST}
      end;


    procedure dir_resource(t:tdirectivetoken);
      var
        s : string;
      begin
        current_scanner^.skipspace;
        s:=current_scanner^.readcomment;
        { replace * with current module name.
          This should always be defined. }
        if s[1]='*' then
          if Assigned(Current_Module) then
            begin
            delete(S,1,1);
            insert(lower(current_module^.modulename^),S,1);
            end;
        s:=AddExtension(FixFileName(s),target_info.resext);
        if target_info.res<>res_none then
          if (target_info.res = res_i386_emx) and
                                 not (Current_Module^.ResourceFiles.Empty) then
            Message(scan_w_only_one_resourcefile_supported)
          else
            current_module^.resourcefiles.insert(FixFileName(s))
        else
          Message(scan_e_resourcefiles_not_supported);
      end;

{$ifndef PAVEL_LINKLIB}
    procedure dir_linklib(t:tdirectivetoken);
      var
        s : string;
        quote : char;
      begin
        current_scanner^.skipspace;
        { This way spaces are also allowed in library names
          if quoted PM }
        if (c='''') or (c='"') then
          begin
            quote:=c;
            current_scanner^.readchar;
            s:=current_scanner^.readcomment;
            if pos(quote,s)>0 then
              s:=copy(s,1,pos(quote,s)-1);
          end
        else
          begin
            current_scanner^.readstring;
            s:=orgpattern;
            if c='.' then
              begin
                s:=s+'.';
                current_scanner^.readchar;
                current_scanner^.readstring;
                s:=s+orgpattern;
              end;
          end;
      {$IFDEF NEWST}
        current_module^.linkOtherSharedLibs.
         insert(new(Plinkitem,init(s,link_allways)));
      {$ELSE}
        current_module^.linkOtherSharedLibs.
         insert(s,link_allways);
      {$ENDIF}
      end;
{$else PAVEL_LINKLIB}
    procedure dir_linklib(t:tdirectivetoken);
      var
       s:string;
       libname,linkmodeStr:string;
       p:longint;
      type
       tLinkMode=(lm_dynamic,lm_static);
      var
       linkMode:tLinkMode;
      function ExtractLinkMode:tLinkMode;
       var
        p:longint;
       begin
        p:=pos(',',linkmodeStr);
        if p>0 then
         linkmodeStr:=copy(linkmodeStr,1,pred(p));
        for p:=1 to length(linkmodeStr)do
         linkmodeStr[p]:=upcase(linkmodeStr[p]);
        if linkmodeStr='STATIC' then
         ExtractLinkMode:=lm_static
        else
         ExtractLinkMode:=lm_dynamic
       end;
      procedure MangleLibName(mode:tLinkMode);
       begin
        if (libname[1]='''')and(libname[length(libname)]='''')then
         begin
          delete(libname,1,1);
          delete(libname,length(libname),1);
         end
        else
         begin
          libname:=target_os.libprefix+libname;
          case mode of
           lm_static:
            libname:=AddExtension(FixFileName(libname),target_os.staticlibext);
           lm_dynamic:
            libname:=AddExtension(FixFileName(libname),target_os.sharedlibext);
          end;
         end;
       end;
      begin
       current_scanner^.skipspace;
       s:=current_scanner^.readcomment;
       p:=pos(',',s);
       if p=0 then
        begin
         libname:=s;
         linkmodeStr:=''
        end
       else
        begin
         libname:=copy(s,1,pred(p));
         linkmodeStr:=copy(s,succ(p),255);
        end;
       if(libname='')or(libname='''''')then
        exit;
       linkMode:=ExtractLinkMode;
       MangleLibName(linkMode);
       if linkMode=lm_static then
{$IFDEF NEWST}
        current_module^.linkOtherStaticLibs.
         insert(new(Plinkitem,init(FixFileName(libname),link_allways)))
{$ELSE}
        current_module^.linkOtherStaticLibs.
         insert(FixFileName(libname),link_allways)
{$ENDIF}
       else
{$IFDEF NEWST}
        current_module^.linkOtherSharedLibs.
         insert(new(Plinkitem,init(FixFileName(libname),link_allways)));
{$ELSE}
        current_module^.linkOtherSharedLibs.
         insert(FixFileName(libname),link_allways);
{$ENDIF}
      end;


{$endif PAVEL_LINKLIB}


    procedure dir_outputformat(t:tdirectivetoken);
      begin
        if not current_module^.in_global then
         Message(scan_w_switch_is_global)
        else
          begin
            current_scanner^.skipspace;
            if set_string_asm(current_scanner^.readid) then
             aktoutputformat:=target_asm.id
            else
             Message(scan_w_illegal_switch);
          end;
      end;


    procedure dir_unitpath(t:tdirectivetoken);
      begin
        if not current_module^.in_global then
         Message(scan_w_switch_is_global)
        else
          begin
            current_scanner^.skipspace;
            current_module^.localunitsearchpath.AddPath(current_scanner^.readcomment,false);
          end;
      end;


    procedure dir_includepath(t:tdirectivetoken);
      begin
        if not current_module^.in_global then
         Message(scan_w_switch_is_global)
        else
          begin
            current_scanner^.skipspace;
            current_module^.localincludesearchpath.AddPath(current_scanner^.readcomment,false);
          end;
      end;


    procedure dir_librarypath(t:tdirectivetoken);
      begin
        if not current_module^.in_global then
         Message(scan_w_switch_is_global)
        else
          begin
            current_scanner^.skipspace;
            current_module^.locallibrarysearchpath.AddPath(current_scanner^.readcomment,false);
          end;
      end;


    procedure dir_objectpath(t:tdirectivetoken);
      begin
        if not current_module^.in_global then
         Message(scan_w_switch_is_global)
        else
          begin
            current_scanner^.skipspace;
            current_module^.localobjectsearchpath.AddPath(current_scanner^.readcomment,false);
          end;
      end;


    procedure dir_mode(t:tdirectivetoken);
      begin
        if not current_module^.in_global then
         Message(scan_w_switch_is_global)
        else
          begin
            current_scanner^.skipspace;
            current_scanner^.readstring;
            if pattern='DEFAULT' then
             aktmodeswitches:=initmodeswitches
            else
             if pattern='DELPHI' then
              aktmodeswitches:=delphimodeswitches
            else
             if pattern='TP' then
              aktmodeswitches:=tpmodeswitches
            else
             if pattern='FPC' then
              aktmodeswitches:=fpcmodeswitches
            else
             if pattern='OBJFPC' then
              aktmodeswitches:=objfpcmodeswitches
            else
             if pattern='GPC' then
              aktmodeswitches:=gpcmodeswitches
            else
             Message(scan_w_illegal_switch);
          end;
      end;


    procedure dir_packrecords(t:tdirectivetoken);
      var
        hs : string;
      begin
        current_scanner^.skipspace;
        if not(c in ['0'..'9']) then
         begin
           hs:=current_scanner^.readid;
           if (hs='C') then
            aktpackrecords:=packrecord_C
           else
            if (hs='NORMAL') or (hs='DEFAULT') then
             aktpackrecords:=packrecord_2
           else
            Message(scan_w_only_pack_records);
         end
        else
         begin
           case current_scanner^.readval of
             1 : aktpackrecords:=packrecord_1;
             2 : aktpackrecords:=packrecord_2;
             4 : aktpackrecords:=packrecord_4;
             8 : aktpackrecords:=packrecord_8;
            16 : aktpackrecords:=packrecord_16;
            32 : aktpackrecords:=packrecord_32;
           else
            Message(scan_w_only_pack_records);
           end;
         end;
      end;

    procedure dir_maxfpuregisters(t:tdirectivetoken);

      var
         l : longint;
         hs : string;

      begin
         current_scanner^.skipspace;
         if not(c in ['0'..'9']) then
           begin
              hs:=current_scanner^.readid;
              if (hs='NORMAL') or (hs='DEFAULT') then
                aktmaxfpuregisters:=-1
              else
                Message(scan_e_invalid_maxfpureg_value);
           end
         else
           begin
              l:=current_scanner^.readval;
              case l of
                 0..8:
                   aktmaxfpuregisters:=l;
                 else
                   Message(scan_e_invalid_maxfpureg_value);
              end;
           end;
      end;


    procedure dir_packenum(t:tdirectivetoken);
      var
        hs : string;
      begin
        if t in [_DIR_Z1,_DIR_Z2,_DIR_Z4] then
         begin
           aktpackenum:=ord(pattern[2])-ord('0');
           exit;
         end;
        current_scanner^.skipspace;
        if not(c in ['0'..'9']) then
         begin
           hs:=current_scanner^.readid;
           if (hs='NORMAL') or (hs='DEFAULT') then
            aktpackenum:=4
           else
            Message(scan_w_only_pack_enum);
         end
        else
         begin
           case current_scanner^.readval of
            1 : aktpackenum:=1;
            2 : aktpackenum:=2;
            4 : aktpackenum:=4;
           else
            Message(scan_w_only_pack_enum);
           end;
         end;
      end;

{$ifdef testvarsets}
    procedure dir_setalloc(t:tdirectivetoken);
      var
        hs : string;
      begin
        current_scanner^.skipspace;
        if not(c in ['1','2','4']) then
         begin
           hs:=current_scanner^.readid;
           if (hs='FIXED') or ((hs='DEFAULT') OR (hs='NORMAL')) then
           aktsetalloc:=0               {Fixed mode, sets are 4 or 32 bytes}
          else
           Message(scan_w_only_packset);
          end
        else
         begin
           case current_scanner^.readval of
            1 : aktpackenum:=1;
            2 : aktpackenum:=2;
            4 : aktpackenum:=4;
           else
            Message(scan_w_only_packset);
           end;
         end;
      end;
{$ENDIF}
    procedure dir_apptype(t:tdirectivetoken);

      var
         hs : string;

      begin
        if target_info.target<>target_i386_win32 then
          Message(scan_w_app_type_not_support);
        if not current_module^.in_global then
          Message(scan_w_switch_is_global)
        else
          begin
             current_scanner^.skipspace;
             hs:=current_scanner^.readid;
             if hs='GUI' then
               apptype:=at_gui
             else if hs='CONSOLE' then
               apptype:=at_cui
             else
               Message1(scan_w_unsupported_app_type,hs);
          end;
      end;

    procedure dir_wait(t:tdirectivetoken);
      var had_info : boolean;
      begin
        had_info:=(status.verbosity and V_Info)<>0;
        { this message should allways appear !! }
        status.verbosity:=status.verbosity or V_Info;
        Message(scan_i_press_enter);
        readln;
        If not(had_info) then
          status.verbosity:=status.verbosity and (not V_Info);
      end;


    procedure dir_asmmode(t:tdirectivetoken);
      var
        s : string;
      begin
        current_scanner^.skipspace;
        s:=current_scanner^.readid;
        If Inside_asm_statement then
          Message1(scan_w_no_asm_reader_switch_inside_asm,s);
        if s='DEFAULT' then
         aktasmmode:=initasmmode
        else
         if not set_string_asmmode(s,aktasmmode) then
          Message1(scan_w_unsupported_asmmode_specifier,s);
      end;


    procedure dir_oldasmmode(t:tdirectivetoken);
      begin
        If Inside_asm_statement then
          Message1(scan_w_no_asm_reader_switch_inside_asm,directive[t]);
{$ifdef i386}
        case t of
         _DIR_I386_ATT    : aktasmmode:=asmmode_i386_att;
         _DIR_I386_DIRECT : aktasmmode:=asmmode_i386_direct;
         _DIR_I386_INTEL  : aktasmmode:=asmmode_i386_intel;
        end;
{$endif i386}
      end;


    procedure dir_delphiswitch(t:tdirectivetoken);
      var
        sw,state : char;
      begin
        case t of
           _DIR_ALIGN : sw:='A';
      _DIR_ASSERTIONS : sw:='C';
        _DIR_BOOLEVAL : sw:='B';
       _DIR_DEBUGINFO : sw:='D';
        _DIR_IOCHECKS : sw:='I';
    _DIR_LOCALSYMBOLS : sw:='L';
     _DIR_LONGSTRINGS : sw:='H';
     _DIR_OPENSTRINGS : sw:='P';
  _DIR_OVERFLOWCHECKS : sw:='Q';
     _DIR_RANGECHECKS : sw:='R';
   _DIR_REFERENCEINFO : sw:='Y';
     _DIR_STACKFRAMES : sw:='W';
    _DIR_TYPEDADDRESS : sw:='T';
        _DIR_TYPEINFO : sw:='M';
 _DIR_VARSTRINGCHECKS : sw:='V';
        else
         exit;
        end;
      { c contains the next char, a + or - would be fine }
        state:=current_scanner^.readstate;
        if state in ['-','+'] then
          HandleSwitch(sw,state);
      end;


    procedure dir_memory(t:tdirectivetoken);
      var
        l : longint;
      begin
        current_scanner^.skipspace;
        l:=current_scanner^.readval;
        if l>1024 then
         stacksize:=l;
        current_scanner^.skipspace;
        if c=',' then
         begin
           current_scanner^.readchar;
           current_scanner^.skipspace;
           l:=current_scanner^.readval;
           if l>1024 then
            heapsize:=l;
         end;
        if c=',' then
         begin
           current_scanner^.readchar;
           current_scanner^.skipspace;
           l:=current_scanner^.readval;
           { Ignore this value, because the limit is set by the OS
             info and shouldn't be changed by the user (PFV) }
         end;
      end;


    procedure dir_setverbose(t:tdirectivetoken);
      var
        flag,
        state : char;
      begin
        case t of
         _DIR_HINTS : flag:='H';
      _DIR_WARNINGS : flag:='W';
         _DIR_NOTES : flag:='N';
        else
         exit;
        end;
      { support ON/OFF }
        state:=current_scanner^.ReadState;
        SetVerbosity(flag+state);
      end;


      type
        tdirectiveproc=procedure(t:tdirectivetoken);
      const
        directiveproc:array[tdirectivetoken] of tdirectiveproc=(
         {_DIR_NONE} nil,
         {_DIR_ALIGN} dir_delphiswitch,
         {_DIR_APPTYPE} dir_apptype,
         {_DIR_ASMMODE} dir_asmmode,
         {_DIR_ASSERTION} dir_delphiswitch,
         {_DIR_BOOLEVAL} dir_delphiswitch,
         {_DIR_D} dir_description,
         {_DIR_DEBUGINFO} dir_delphiswitch,
         {_DIR_DEFINE} dir_define,
         {_DIR_DESCRIPTION} dir_description,
         {_DIR_ELSE} dir_conditional,
         {_DIR_ENDIF} dir_conditional,
         {_DIR_ERROR} dir_message,
         {_DIR_EXTENDEDSYNTAX} dir_delphiswitch,
         {_DIR_FATAL} dir_message,
         {_DIR_GOTO} dir_moduleswitch,
         {_DIR_HINT} dir_message,
         {_DIR_HINTS} dir_setverbose,
         {_DIR_I} dir_include,
         {_DIR_I386_ATT} dir_oldasmmode,
         {_DIR_I386_DIRECT} dir_oldasmmode,
         {_DIR_I386_INTEL} dir_oldasmmode,
         {_DIR_IOCHECKS} dir_delphiswitch,
         {_DIR_IF} dir_conditional,
         {_DIR_IFDEF} dir_conditional,
         {_DIR_IFNDEF} dir_conditional,
         {_DIR_IFOPT} dir_conditional,
         {_DIR_INCLUDE} dir_include,
         {_DIR_INCLUDEPATH} dir_includepath,
         {_DIR_INFO} dir_message,
         {_DIR_INLINE} dir_moduleswitch,
         {_DIR_L} dir_linkobject,
         {_DIR_LIBRARYPATH} dir_librarypath,
         {_DIR_LINK} dir_linkobject,
         {_DIR_LINKLIB} dir_linklib,
         {_DIR_LOCALSYMBOLS} dir_delphiswitch,
         {_DIR_LONGSTRINGS} dir_delphiswitch,
         {_DIR_M} dir_memory,
         {_DIR_MACRO} dir_moduleswitch,
         {_DIR_MAXFPUREGISTERS} dir_maxfpuregisters,
         {_DIR_MEMORY} dir_memory,
         {_DIR_MESSAGE} dir_message,
         {_DIR_MINENUMSIZE} dir_packenum,
         {_DIR_MMX} dir_localswitch,
         {_DIR_MODE} dir_mode,
         {_DIR_NOTE} dir_message,
         {_DIR_NOTES} dir_setverbose,
         {_DIR_OBJECTPATH} dir_objectpath,
         {_DIR_OPENSTRINGS} dir_delphiswitch,
         {_DIR_OUTPUT_FORMAT} dir_outputformat,
         {_DIR_OVERFLOWCHECKS} dir_delphiswitch,
         {_DIR_PACKENUM} dir_packenum,
         {_DIR_PACKRECORDS} dir_packrecords,
         {$IFDEF TestVarsets}
         {_DIR_PACKSET} dir_packset,
         {$ENDIF}
         {_DIR_R} dir_resource,
         {_DIR_RANGECHECKS} dir_delphiswitch,
         {_DIR_REFERENCEINFO} dir_delphiswitch,
         {_DIR_SATURATION} dir_localswitch,
         {_DIR_SMARTLINK} dir_moduleswitch,
         {_DIR_STACKFRAMES} dir_delphiswitch,
         {_DIR_STATIC} dir_moduleswitch,
         {_DIR_STOP} dir_message,
         {_DIR_TYPEDADDRESS} dir_delphiswitch,
         {_DIR_TYPEINFO} dir_delphiswitch,
         {_DIR_UNDEF} dir_undef,
         {_DIR_UNITPATH} dir_unitpath,
         {_DIR_VARSTRINGCHECKS} dir_delphiswitch,
         {_DIR_VERSION} dir_version,
         {_DIR_WAIT} dir_wait,
         {_DIR_WARNING} dir_message,
         {_DIR_WARNINGS} dir_setverbose,
         {_DIR_Z1} dir_packenum,
         {_DIR_Z2} dir_packenum,
         {_DIR_Z4} dir_packenum
         );

  {-------------------------------------------
            Main switches handling
  -------------------------------------------}

    procedure handledirectives;
      var
        t  : tdirectivetoken;
        p  : tdirectiveproc;
        hs : string;
      begin
         current_scanner^.gettokenpos;
         current_scanner^.readchar; {Remove the $}
         hs:=current_scanner^.readid;
         if parapreprocess then
          begin
            t:=Get_Directive(hs);
            if not(is_conditional(t) or (t=_DIR_DEFINE) or (t=_DIR_UNDEF)) then
             begin
               preprocfile^.AddSpace;
               preprocfile^.Add('{$'+hs+current_scanner^.readcomment+'}');
               exit;
             end;
          end;
         { skip this directive? }
         if current_scanner^.ignoredirectives.find(hs) then
          begin
            if (current_scanner^.comment_level>0) then
             current_scanner^.readcomment;
            { we've read the whole comment }
            aktcommentstyle:=comment_none;
            exit;
          end;
         if hs='' then
          begin
            Message1(scan_w_illegal_switch,'$'+hs);
          end;
      { Check for compiler switches }
         while (length(hs)=1) and (c in ['-','+']) do
          begin
            HandleSwitch(hs[1],c);
            current_scanner^.readchar; {Remove + or -}
            if c=',' then
             begin
               current_scanner^.readchar;   {Remove , }
             { read next switch, support $v+,$+}
               hs:=current_scanner^.readid;
               if (hs='') then
                begin
                  if (c='$') and (m_fpc in aktmodeswitches) then
                   begin
                     current_scanner^.readchar;  { skip $ }
                     hs:=current_scanner^.readid;
                   end;
                  if (hs='') then
                   Message1(scan_w_illegal_directive,'$'+c);
                end
               else
                Message1(scan_d_handling_switch,'$'+hs);
             end
            else
             hs:='';
          end;
      { directives may follow switches after a , }
         if hs<>'' then
          begin
            t:=Get_Directive(hs);
            if t<>_DIR_NONE then
             begin
               p:=directiveproc[t];
             {$ifndef TP}
               if assigned(p) then
             {$else}
               if @p<>nil then
             {$endif}
                p(t);
             end
            else
             begin
               current_scanner^.ignoredirectives.insert(hs);
               Message1(scan_w_illegal_directive,'$'+hs);
             end;
          { conditionals already read the comment }
            if (current_scanner^.comment_level>0) then
             current_scanner^.readcomment;
            { we've read the whole comment }
            aktcommentstyle:=comment_none;
          end;
      end;

{
  $Log$
  Revision 1.6  2000-09-11 17:00:23  florian
    + first implementation of Netware Module support, thanks to
      Armin Diehl ([email protected]) for providing the patches

  Revision 1.5  2000/09/10 21:18:15  peter
    * macro warning (merged)

  Revision 1.4  2000/08/12 15:30:44  peter
    * IDE patch for stream reading (merged)

  Revision 1.3  2000/08/08 19:28:57  peter
    * memdebug/memory patches (merged)
    * only once illegal directive (merged)

  Revision 1.2  2000/07/13 11:32:49  michael
  + removed logs

}