freepascal.compiler/compiler/parser.pas

{
    $Id$
    Copyright (c) 1993-98 by Florian Klaempfl

    This unit does the parsing process

    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.

 ****************************************************************************
}
{$ifdef tp}
  {$E+,N+,D+,F+}
{$endif}
unit parser;

  interface

    procedure compile(const filename:string;compile_system:boolean);
    procedure initparser;

  implementation

    uses
       dos,cobjects,globals,scanner,systems,symtable,tree,aasm,
       types,strings,pass_1,hcodegen,files,verbose,script,import
{$ifdef i386}
       ,i386
       ,cgi386
       ,cgai386
       ,tgeni386
       ,aopt386
{$endif i386}
{$ifdef m68k}
        ,m68k
        ,cg68k
        ,tgen68k
        ,cga68k
{$endif m68k}
       { parser units }
       ,pbase,pmodules,pdecl,
       { assembling & linking }
       assemble,
       link;

  { dummy variable for search when calling exec }
  var
     file_found : boolean;

    procedure readconstdefs;

      begin
         s32bitdef:=porddef(globaldef('longint'));
         u32bitdef:=porddef(globaldef('ulong'));
         cstringdef:=pstringdef(globaldef('string'));
         clongstringdef:=pstringdef(globaldef('longstring'));
         cansistringdef:=pstringdef(globaldef('ansistring'));
         cwidestringdef:=pstringdef(globaldef('widestring'));
         cchardef:=porddef(globaldef('char'));
{$ifdef i386}
         c64floatdef:=pfloatdef(globaldef('s64real'));
{$endif}
{$ifdef m68k}
         c64floatdef:=pfloatdef(globaldef('s32real'));
{$endif m68k}
         s80floatdef:=pfloatdef(globaldef('s80real'));
         s32fixeddef:=pfloatdef(globaldef('cs32fixed'));
         voiddef:=porddef(globaldef('void'));
         u8bitdef:=porddef(globaldef('byte'));
         u16bitdef:=porddef(globaldef('word'));
         booldef:=porddef(globaldef('boolean'));
         voidpointerdef:=ppointerdef(globaldef('void_pointer'));
         cfiledef:=pfiledef(globaldef('file'));
      end;

    procedure initparser;

      begin
         forwardsallowed:=false;

         { ^M means a string or a char, because we don't parse a }
         { type declaration                                      }
         block_type:=bt_general;
         ignore_equal:=false;

         { we didn't parse a object or class declaration }
         { and no function header                        }
         testcurobject:=0;

         { create error defintion }
         generrordef:=new(perrordef,init);

         symtablestack:=nil;

         { a long time, this was forgotten }
         aktprocsym:=nil;

         current_module:=nil;

         loaded_units.init;

         usedunits.init;
      end;

    { moved out to save stack }
    var
       addparam : string;

    procedure compile(const filename:string;compile_system:boolean);
      var
         hp : pmodule;

         { some variables to save the compiler state }
         oldtoken : ttoken;
{$ifdef UseTokenInfo}
         oldtokenpos : tfileposinfo;
{$endif UseTokenInfo}
         oldpattern : stringid;

         oldpreprocstack : ppreprocstack;
         oldorgpattern,oldprocprefix : string;
         old_block_type : tblock_type;
         oldinputbuffer,
         oldinputpointer : pchar;
         olds_point,oldparse_only : boolean;
         oldc : char;
         oldcomment_level : word;

         oldimports,oldexports,oldresource,oldrttilist,
         oldbsssegment,olddatasegment,oldcodesegment,
         oldexprasmlist,olddebuglist,
         oldinternals,oldexternals,oldconsts : paasmoutput;


         oldnextlabelnr : longint;

         oldswitches : Tcswitches;
         oldmacros,oldrefsymtable,oldsymtablestack : psymtable;


      procedure def_macro(const s : string);

        var
          mac : pmacrosym;

        begin
           mac:=pmacrosym(macros^.search(s));
           if mac=nil then
             begin
               mac:=new(pmacrosym,init(s));
               Message1(parser_m_macro_defined,mac^.name);
               macros^.insert(mac);
             end;
           mac^.defined:=true;
        end;

      procedure set_macro(const s : string;value : string);

        var
          mac : pmacrosym;

        begin
           mac:=pmacrosym(macros^.search(s));
           if mac=nil then
             begin
               mac:=new(pmacrosym,init(s));
               macros^.insert(mac);
             end
           else
             begin
                if assigned(mac^.buftext) then
                  freemem(mac^.buftext,mac^.buflen);
             end;
           Message2(parser_m_macro_set_to,mac^.name,value);
           mac^.buflen:=length(value);
           getmem(mac^.buftext,mac^.buflen);
           move(value[1],mac^.buftext^,mac^.buflen);
           mac^.defined:=true;
        end;

      procedure define_macros;

        var
           hp : pstring_item;

        begin
           hp:=pstring_item(commandlinedefines.first);
           while assigned(hp) do
             begin
               def_macro(hp^.str^);
               hp:=pstring_item(hp^.next);
             end;

           { set macros for version checking }
           set_macro('FPC_VERSION',version_nr);
           set_macro('FPC_RELEASE',release_nr);
           set_macro('FPC_PATCH',patch_nr);
        end;

      label
         done;

      begin {compile}
         inc(compile_level);
         { save old state }

         { save symtable state }
         oldsymtablestack:=symtablestack;
         symtablestack:=nil;
         oldrefsymtable:=refsymtable;
         refsymtable:=nil;
         oldprocprefix:=procprefix;

         { a long time, this was only in init_parser
           but it should be reset to zero for each module }
         aktprocsym:=nil;

         { first, we assume a program }
         if not(assigned(current_module)) then
           begin
              current_module:=new(pmodule,init(filename,false));
              main_module:=current_module;
           end;

         { save scanner state }
         oldmacros:=macros;
         oldpattern:=pattern;
         oldtoken:=token;
{$ifdef UseTokenInfo}
         oldtokenpos:=tokenpos;
{$endif UseTokenInfo}
         oldorgpattern:=orgpattern;
         old_block_type:=block_type;
         oldpreprocstack:=preprocstack;

         oldinputbuffer:=inputbuffer;
         oldinputpointer:=inputpointer;
         olds_point:=s_point;
         oldc:=c;
         oldcomment_level:=comment_level;

         oldparse_only:=parse_only;

         { save assembler lists }
         olddatasegment:=datasegment;
         oldbsssegment:=bsssegment;
         oldcodesegment:=codesegment;
         olddebuglist:=debuglist;
         oldexternals:=externals;
         oldinternals:=internals;
         oldconsts:=consts;
         oldrttilist:=rttilist;
         oldexprasmlist:=exprasmlist;
         oldimports:=importssection;
         oldexports:=exportssection;
         oldresource:=resourcesection;

         oldswitches:=aktswitches;
         oldnextlabelnr:=nextlabelnr;

         Message1(parser_i_compiling,filename);

         InitScanner(filename);

         aktswitches:=initswitches;

         { we need this to make the system unit }
         if compile_system then
          aktswitches:=aktswitches+[cs_compilesystem];

         aktpackrecords:=initpackrecords;

         { init code generator for a new module }
         codegen_newmodule;
         macros:=new(psymtable,init(macrosymtable));

         define_macros;

         { startup scanner }
         token:=yylex;

         reset_gdb_info;
         { init asm writing }
         datasegment:=new(paasmoutput,init);
         codesegment:=new(paasmoutput,init);
         bsssegment:=new(paasmoutput,init);
         debuglist:=new(paasmoutput,init);
         externals:=new(paasmoutput,init);
         internals:=new(paasmoutput,init);
         consts:=new(paasmoutput,init);
         rttilist:=new(paasmoutput,init);
         importssection:=nil;
         exportssection:=nil;
         resourcesection:=nil;

         { global switches are read, so further changes aren't allowed }
         current_module^.in_main:=true;

         { open assembler response }
         if (compile_level=1) then
          AsmRes.Init('ppas');

         { if the current file isn't a system unit  }
         { the the system unit will be loaded       }
         if not(cs_compilesystem in aktswitches) then
           begin
              { should be done in unit system (changing the field system_unit)
                                                                      FK
              }
              hp:=loadunit(upper(target_info.system_unit),true,true);
              systemunit:=hp^.symtable;
              readconstdefs;
              { we could try to overload caret by default }
              symtablestack:=systemunit;
              { if POWER is defined in the RTL then use it for starstar overloading }
              getsym('POWER',false);
              if assigned(srsym) and (srsym^.typ=procsym) and
                 (overloaded_operators[STARSTAR]=nil) then
                overloaded_operators[STARSTAR]:=pprocsym(srsym);
           end
         else
           begin
              { create definitions for constants }
              registerdef:=false;
              s32bitdef:=new(porddef,init(s32bit,$80000000,$7fffffff));
              u32bitdef:=new(porddef,init(u32bit,0,$ffffffff));
              cstringdef:=new(pstringdef,init(255));
              { should we give a length to the default long and ansi string definition ?? }
              clongstringdef:=new(pstringdef,longinit(-1));
              cansistringdef:=new(pstringdef,ansiinit(-1));
              cwidestringdef:=new(pstringdef,wideinit(-1));
              cchardef:=new(porddef,init(uchar,0,255));
{$ifdef i386}
              c64floatdef:=new(pfloatdef,init(s64real));
              s80floatdef:=new(pfloatdef,init(s80real));
{$endif}
{$ifdef m68k}
              c64floatdef:=new(pfloatdef,init(s32real));
              if (cs_fp_emulation in aktswitches) then
               s80floatdef:=new(pfloatdef,init(s32real))
              else
               s80floatdef:=new(pfloatdef,init(s80real));
{$endif}
              s32fixeddef:=new(pfloatdef,init(f32bit));

              { some other definitions }
              voiddef:=new(porddef,init(uvoid,0,0));
              u8bitdef:=new(porddef,init(u8bit,0,255));
              u16bitdef:=new(porddef,init(u16bit,0,65535));
              booldef:=new(porddef,init(bool8bit,0,1));
              voidpointerdef:=new(ppointerdef,init(voiddef));
              cfiledef:=new(pfiledef,init(ft_untyped,nil));
              systemunit:=nil;
           end;
         registerdef:=true;

         { current return type is void }
         procinfo.retdef:=voiddef;

         { reset lexical level }
         lexlevel:=0;

         { parse source }
         if (token=_UNIT) or (compile_level>1) then
           begin
             current_module^.is_unit:=true;
           { If the compile level > 1 we get a nice "unit expected" error
             message if we are trying to use a program as unit.}
             proc_unit;
             if current_module^.compiled then
               goto done;
           end
         else
           begin
             proc_program(token=_LIBRARY);
           end;

         if errorcount=0 then
           begin
             if current_module^.uses_imports then
              importlib^.generatelib;

             GenerateAsm(filename);

             if smartlink then
              begin
                Linker.SetLibName(FileName);
                Linker.MakeStaticLibrary(SmartLinkPath(FileName),SmartLinkFilesCnt);
              end;

           { add the files for the linker from current_module, this must be
             after the makestaticlibrary, because it will add the library
             name (PFV) }
             addlinkerfiles(current_module);

           { Check linking  => we are at first level in compile }
             if (compile_level=1) and (not current_module^.is_unit) then
               begin
                 if (cs_no_linking in initswitches) then
                   externlink:=true;
                 if Linker.ExeName='' then
                   Linker.SetExeName(FileName);
                 Linker.MakeExecutable;
               end;
           end
         else
           Message1(unit_f_errors_in_unit,tostr(errorcount));
        

done:
         { clear memory }
{$ifdef Splitheap}
         if testsplit then
           begin
           { temp heap should be empty after that !!!}
             codegen_donemodule;
             Releasetempheap;
           end;
{$endif Splitheap}

         { restore old state, close trees }
         if dispose_asm_lists then
           codegen_donemodule;

         reset_gdb_info;
         { restore symtable state }
{$ifdef UseBrowser}
         if (compile_level>1) then
{ we want to keep the current symtablestack }
{$endif UseBrowser}
           begin
              refsymtable:=oldrefsymtable;
              symtablestack:=oldsymtablestack;
           end;

         procprefix:=oldprocprefix;

         { close the inputfiles }
{$ifndef UseBrowser}
         { but not if we want the names for the browser ! }
         current_module^.sourcefiles.done;
{$endif not UseBrowser}
         { restore scanner state }
         pattern:=oldpattern;
         token:=oldtoken;
{$ifdef UseTokenInfo}
         tokenpos:=oldtokenpos;
{$endif UseTokenInfo}
         orgpattern:=oldorgpattern;
         block_type:=old_block_type;

         { call donescanner before restoring preprocstack, because }
         { donescanner tests for a empty preprocstack              }
         { and can also check for unused macros                    }
         donescanner(current_module^.compiled);
         dispose(macros,done);
         macros:=oldmacros;


         preprocstack:=oldpreprocstack;

         aktswitches:=oldswitches;
         inputbuffer:=oldinputbuffer;
         inputpointer:=oldinputpointer;
         s_point:=olds_point;
         c:=oldc;
         comment_level:=oldcomment_level;

         parse_only:=oldparse_only;

         { restore asmlists }
         datasegment:=olddatasegment;
         bsssegment:=oldbsssegment;
         codesegment:=oldcodesegment;
         consts:=oldconsts;
         debuglist:=olddebuglist;
         externals:=oldexternals;
         internals:=oldinternals;
         importssection:=oldimports;
         exportssection:=oldexports;
         resourcesection:=oldresource;

         nextlabelnr:=oldnextlabelnr;
         exprasmlist:=oldexprasmlist;

         if (compile_level=1) then
          begin
            if (not AsmRes.Empty) then
             begin
               Message1(exec_i_closing_script,AsmRes.Fn);
               AsmRes.WriteToDisk;
             end;
          end;
         dec(compile_level);
      end;

end.
{
  $Log$
  Revision 1.16  1998-05-12 10:47:00  peter
    * moved printstatus to verb_def
    + V_Normal which is between V_Error and V_Warning and doesn't have a
      prefix like error: warning: and is included in V_Default
    * fixed some messages
    * first time parameter scan is only for -v and -T
    - removed old style messages

  Revision 1.15  1998/05/11 13:07:54  peter
    + $ifdef NEWPPU for the new ppuformat
    + $define GDB not longer required
    * removed all warnings and stripped some log comments
    * no findfirst/findnext anymore to remove smartlink *.o files

  Revision 1.14  1998/05/06 18:36:53  peter
    * tai_section extended with code,data,bss sections and enumerated type
    * ident 'compiled by FPC' moved to pmodules
    * small fix for smartlink

  Revision 1.13  1998/05/06 08:38:42  pierre
    * better position info with UseTokenInfo
      UseTokenInfo greatly simplified
    + added check for changed tree after first time firstpass
      (if we could remove all the cases were it happen
      we could skip all firstpass if firstpasscount > 1)
      Only with ExtDebug

  Revision 1.12  1998/05/04 17:54:28  peter
    + smartlinking works (only case jumptable left todo)
    * redesign of systems.pas to support assemblers and linkers
    + Unitname is now also in the PPU-file, increased version to 14

  Revision 1.11  1998/05/01 16:38:45  florian
    * handling of private and protected fixed
    + change_keywords_to_tp implemented to remove
      keywords which aren't supported by tp
    * break and continue are now symbols of the system unit
    + widestring, longstring and ansistring type released

  Revision 1.10  1998/05/01 07:43:56  florian
    + basics for rtti implemented
    + switch $m (generate rtti for published sections)

  Revision 1.9  1998/04/30 15:59:40  pierre
    * GDB works again better :
      correct type info in one pass
    + UseTokenInfo for better source position
    * fixed one remaining bug in scanner for line counts
    * several little fixes

  Revision 1.8  1998/04/29 10:33:55  pierre
    + added some code for ansistring (not complete nor working yet)
    * corrected operator overloading
    * corrected nasm output
    + started inline procedures
    + added starstarn : use ** for exponentiation (^ gave problems)
    + started UseTokenInfo cond to get accurate positions

  Revision 1.7  1998/04/27 23:10:28  peter
    + new scanner
    * $makelib -> if smartlink
    * small filename fixes pmodule.setfilename
    * moved import from files.pas -> import.pas

  Revision 1.6  1998/04/21 10:16:48  peter
    * patches from strasbourg
    * objects is not used anymore in the fpc compiled version

  Revision 1.5  1998/04/10 14:41:43  peter
    * removed some Hints
    * small speed optimization for AsmLn

  Revision 1.4  1998/04/08 16:58:03  pierre
    * several bugfixes
      ADD ADC and AND are also sign extended
      nasm output OK (program still crashes at end
      and creates wrong assembler files !!)
      procsym types sym in tdef removed !!

  Revision 1.3  1998/04/07 22:45:04  florian
    * bug0092, bug0115 and bug0121 fixed
    + packed object/class/array
}