fpc/compiler/psub.pas

{
    $Id$
    Copyright (c) 1998-2000 by Florian Klaempfl, Daniel Mantione

    Does the parsing of the procedures/functions

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************
}
unit psub;
interface

uses
  cobjects,
  symconst,tokens,symtable;

const
  pd_global    = $1;    { directive must be global }
  pd_body      = $2;    { directive needs a body }
  pd_implemen  = $4;    { directive can be used implementation section }
  pd_interface = $8;    { directive can be used interface section }
  pd_object    = $10;   { directive can be used object declaration }
  pd_procvar   = $20;   { directive can be used procvar declaration }
  pd_notobject    = $40;{ directive can not be used object declaration }

procedure compile_proc_body(const proc_names:Tstringcontainer;
                            make_global,parent_has_class:boolean);
procedure parse_proc_head(options:tproctypeoption);
procedure parse_proc_dec;
function  is_proc_directive(tok:ttoken):boolean;
procedure parse_var_proc_directives(var sym : psym);
procedure parse_object_proc_directives(var sym : pprocsym);
procedure read_proc;

implementation

uses
  globtype,systems,
  strings,globals,verbose,files,
  scanner,aasm,tree,types,
  import,gendef,
{$ifdef newcg}
  cgbase,
{$else newcg}
  hcodegen,temp_gen,
{$endif newcg}
  pass_1,cpubase,cpuasm
{$ifndef NOPASS2}
  ,pass_2
{$endif}
{$ifdef GDB}
  ,gdb
{$endif GDB}
{$ifdef newcg}
  {$ifndef NOOPT}
    ,aopt
  {$endif}
{$else}
  {$ifdef i386}
    ,tgeni386
    ,cgai386
    {$ifndef NOOPT}
      ,aopt386
    {$endif}
  {$endif}
  {$ifdef m68k}
    ,tgen68k,cga68k
  {$endif}
{$endif newcg}
  { parser specific stuff }
  ,pbase,ptype,pdecl,pexpr,pstatmnt
{$ifdef newcg}
  ,tgcpu,convtree,cgobj,tgeni386  { for the new code generator tgeni386 is only a dummy }
{$endif newcg}
  ;

var
  realname:string;  { contains the real name of a procedure as it's typed }


procedure parse_proc_head(options:tproctypeoption);
var sp:stringid;
    pd:Pprocdef;
    paramoffset:longint;
    sym:Psym;
    hs:string;
    st : psymtable;
    overloaded_level:word;
    storepos,procstartfilepos : tfileposinfo;
begin
{ Save the position where this procedure really starts and set col to 1 which
  looks nicer }
  procstartfilepos:=tokenpos;
{  procstartfilepos.column:=1; I do not agree here !!
   lets keep excat position PM }

  if (options=potype_operator) then
    begin
      sp:=overloaded_names[optoken];
      realname:=sp;
    end
  else
    begin
      sp:=pattern;
      realname:=orgpattern;
      consume(_ID);
    end;

{ method ? }
  if not(parse_only) and
     (lexlevel=normal_function_level) and
     try_to_consume(_POINT) then
   begin
     storepos:=tokenpos;
     tokenpos:=procstartfilepos;
     getsym(sp,true);
     sym:=srsym;
     tokenpos:=storepos;
     { load proc name }
     sp:=pattern;
     realname:=orgpattern;
     procstartfilepos:=tokenpos;
     { qualifier is class name ? }
     if (sym^.typ<>typesym) or
        (ptypesym(sym)^.restype.def^.deftype<>objectdef) then
       begin
          Message(parser_e_class_id_expected);
          aktprocsym:=nil;
          consume(_ID);
       end
     else
       begin
          { used to allow private syms to be seen }
          aktobjectdef:=pobjectdef(ptypesym(sym)^.restype.def);
          procinfo^._class:=pobjectdef(ptypesym(sym)^.restype.def);
          aktprocsym:=pprocsym(procinfo^._class^.symtable^.search(sp));
          consume(_ID);
          {The procedure has been found. So it is
           a global one. Set the flags to mark this.}
          procinfo^.flags:=procinfo^.flags or pi_is_global;
          aktobjectdef:=nil;
          { we solve this below }
          if not(assigned(aktprocsym)) then
            Message(parser_e_methode_id_expected);
       end;
   end
  else
   begin
     { check for constructor/destructor which is not allowed here }
     if (not parse_only) and
        (options in [potype_constructor,potype_destructor]) then
        Message(parser_e_constructors_always_objects);

     tokenpos:=procstartfilepos;
     aktprocsym:=pprocsym(symtablestack^.search(sp));

     if not(parse_only) then
       begin
         {The procedure we prepare for is in the implementation
          part of the unit we compile. It is also possible that we
          are compiling a program, which is also some kind of
          implementaion part.

          We need to find out if the procedure is global. If it is
          global, it is in the global symtable.}
         if not assigned(aktprocsym) and
            (symtablestack^.symtabletype=staticsymtable) then
          begin
            {Search the procedure in the global symtable.}
            aktprocsym:=Pprocsym(search_a_symtable(sp,globalsymtable));
            if assigned(aktprocsym) then
             begin
               {Check if it is a procedure.}
               if aktprocsym^.typ<>procsym then
                DuplicateSym(aktprocsym);
               {The procedure has been found. So it is
                a global one. Set the flags to mark this.}
               procinfo^.flags:=procinfo^.flags or pi_is_global;
             end;
          end;
       end;
   end;

{ Create the mangledname }
{$ifndef UseNiceNames}
  if assigned(procinfo^._class) then
   begin
     if (pos('_$$_',procprefix)=0) then
      hs:=procprefix+'_$$_'+procinfo^._class^.objname^+'_$$_'+sp
     else
      hs:=procprefix+'_$'+sp;
   end
  else
   begin
     if lexlevel=normal_function_level then
      hs:=procprefix+'_'+sp
     else
      hs:=procprefix+'_$'+sp;
   end;
{$else UseNiceNames}
  if assigned(procinfo^._class) then
   begin
     if (pos('_5Class_',procprefix)=0) then
      hs:=procprefix+'_5Class_'+procinfo^._class^.name^+'_'+tostr(length(sp))+sp
     else
      hs:=procprefix+'_'+tostr(length(sp))+sp;
   end
  else
   begin
     if lexlevel=normal_function_level then
      hs:=procprefix+'_'+tostr(length(sp))+sp
     else
      hs:=lowercase(procprefix)+'_'+tostr(length(sp))+sp;
   end;
{$endif UseNiceNames}

  if assigned(aktprocsym) then
   begin
     { Check if overloading is enabled }
     if not(m_fpc in aktmodeswitches) then
      begin
        if aktprocsym^.typ<>procsym then
         begin
           DuplicateSym(aktprocsym);
           { try to recover by creating a new aktprocsym }
           tokenpos:=procstartfilepos;
           aktprocsym:=new(pprocsym,init(sp));
         end
        else
         begin
           if not(aktprocsym^.definition^.forwarddef) then
            Message(parser_e_procedure_overloading_is_off);
         end;
      end
     else
      begin
        { Check if the overloaded sym is realy a procsym }
        if aktprocsym^.typ<>procsym then
         begin
           Message1(parser_e_overloaded_no_procedure,aktprocsym^.name);
           { try to recover by creating a new aktprocsym }
           tokenpos:=procstartfilepos;
           aktprocsym:=new(pprocsym,init(sp));
         end;
      end;
   end
  else
   begin
     { create a new procsym and set the real filepos }
     tokenpos:=procstartfilepos;
     aktprocsym:=new(pprocsym,init(sp));
     { for operator we have only one definition for each overloaded
       operation }
{$ifdef DONOTCHAINOPERATORS}
     if (options=potype_operator) then
       begin
          { the only problem is that nextoverloaded might not be in a unit
            known for the unit itself }
          if assigned(overloaded_operators[optoken]) then
            aktprocsym^.definition:=overloaded_operators[optoken]^.definition;
       end;
{$endif DONOTCHAINOPERATORS}
     symtablestack^.insert(aktprocsym);
   end;

  st:=symtablestack;
  pd:=new(pprocdef,init);
  pd^.symtablelevel:=symtablestack^.symtablelevel;

  if assigned(procinfo^._class) then
    pd^._class := procinfo^._class;

  { set the options from the caller (podestructor or poconstructor) }
  pd^.proctypeoption:=options;

  { calculate the offset of the parameters }
  paramoffset:=8;

  { calculate frame pointer offset }
  if lexlevel>normal_function_level then
    begin
      procinfo^.framepointer_offset:=paramoffset;
      inc(paramoffset,target_os.size_of_pointer);
      { this is needed to get correct framepointer push for local
        forward functions !! }
      pd^.parast^.symtablelevel:=lexlevel;
    end;

  if assigned (procinfo^._Class)  and
     not(procinfo^._Class^.is_class) and
     (pd^.proctypeoption in [potype_constructor,potype_destructor]) then
    inc(paramoffset,target_os.size_of_pointer);

  { self pointer offset                       }
  { self isn't pushed in nested procedure of methods }
  if assigned(procinfo^._class) and (lexlevel=normal_function_level) then
    begin
      procinfo^.selfpointer_offset:=paramoffset;
      if assigned(aktprocsym^.definition) and
         not(po_containsself in aktprocsym^.definition^.procoptions) then
        inc(paramoffset,target_os.size_of_pointer);
    end;

  { con/-destructor flag ? }
  if assigned (procinfo^._Class) and
     procinfo^._class^.is_class and
     (pd^.proctypeoption in [potype_destructor,potype_constructor]) then
    inc(paramoffset,target_os.size_of_pointer);

  procinfo^.para_offset:=paramoffset;

  pd^.parast^.datasize:=0;

  pd^.nextoverloaded:=aktprocsym^.definition;
  aktprocsym^.definition:=pd;
  { this is probably obsolete now PM }
  aktprocsym^.definition^.fileinfo:=procstartfilepos;
  aktprocsym^.definition^.setmangledname(hs);
  aktprocsym^.definition^.procsym:=aktprocsym;

  if not parse_only then
    begin
       overloaded_level:=0;
       { we need another procprefix !!! }
       { count, but only those in the same unit !!}
       while assigned(pd) and
          (pd^.owner^.symtabletype in [globalsymtable,staticsymtable]) do
         begin
            { only count already implemented functions }
            if  not(pd^.forwarddef) then
              inc(overloaded_level);
            pd:=pd^.nextoverloaded;
         end;
       if overloaded_level>0 then
         procprefix:=hs+'$'+tostr(overloaded_level)+'$'
       else
         procprefix:=hs+'$';
    end;

  { this must also be inserted in the right symtable !! PM }
  { otherwise we get subbtle problems with
    definitions of args defs in staticsymtable for
    implementation of a global method }
  if token=_LKLAMMER then
    parameter_dec(aktprocsym^.definition);

  { so we only restore the symtable now }
  symtablestack:=st;
  if (options=potype_operator) then
    overloaded_operators[optoken]:=aktprocsym;
end;


procedure parse_proc_dec;
var
  hs : string;
  isclassmethod : boolean;
begin
  inc(lexlevel);
{ read class method }
  if token=_CLASS then
   begin
     consume(_CLASS);
     isclassmethod:=true;
   end
  else
   isclassmethod:=false;
  case token of
     _FUNCTION : begin
                   consume(_FUNCTION);
                   parse_proc_head(potype_none);
                   if token<>_COLON then
                    begin
                       if not(aktprocsym^.definition^.forwarddef) or
                         (m_repeat_forward in aktmodeswitches) then
                       begin
                         consume(_COLON);
                         consume_all_until(_SEMICOLON);
                       end;
                    end
                   else
                    begin
                      consume(_COLON);
                      inc(testcurobject);
                      single_type(aktprocsym^.definition^.rettype,hs,false);
                      aktprocsym^.definition^.test_if_fpu_result;
                      dec(testcurobject);
                    end;
                 end;
    _PROCEDURE : begin
                   consume(_PROCEDURE);
                   parse_proc_head(potype_none);
                   aktprocsym^.definition^.rettype.def:=voiddef;
                 end;
  _CONSTRUCTOR : begin
                   consume(_CONSTRUCTOR);
                   parse_proc_head(potype_constructor);
                   if assigned(procinfo^._class) and
                      procinfo^._class^.is_class then
                    begin
                      { CLASS constructors return the created instance }
                      aktprocsym^.definition^.rettype.def:=procinfo^._class;
                    end
                   else
                    begin
                      { OBJECT constructors return a boolean }
{$IfDef GDB}
                      { GDB doesn't like unnamed types !}
                      aktprocsym^.definition^.rettype.def:=globaldef('boolean');
{$else GDB}
                      aktprocsym^.definition^.rettype.def:=new(porddef,init(bool8bit,0,1));
{$Endif GDB}
                    end;
                 end;
   _DESTRUCTOR : begin
                   consume(_DESTRUCTOR);
                   parse_proc_head(potype_destructor);
                   aktprocsym^.definition^.rettype.def:=voiddef;
                 end;
     _OPERATOR : begin
                   if lexlevel>normal_function_level then
                     Message(parser_e_no_local_operator);
                   consume(_OPERATOR);
                   if not(token in [_PLUS..last_overloaded]) then
                     Message(parser_e_overload_operator_failed);
                   optoken:=token;
                   consume(Token);
                   procinfo^.flags:=procinfo^.flags or pi_operator;
                   parse_proc_head(potype_operator);
                   if token<>_ID then
                     begin
                        opsym:=nil;
                        if not(m_result in aktmodeswitches) then
                          consume(_ID);
                     end
                   else
                     begin
                       opsym:=new(pvarsym,initdef(pattern,voiddef));
                       consume(_ID);
                     end;
                   if not try_to_consume(_COLON) then
                     begin
                       consume(_COLON);
                       aktprocsym^.definition^.rettype.def:=generrordef;
                       consume_all_until(_SEMICOLON);
                     end
                   else
                    begin
                      single_type(aktprocsym^.definition^.rettype,hs,false);
                      aktprocsym^.definition^.test_if_fpu_result;
                      if (optoken in [_EQUAL,_GT,_LT,_GTE,_LTE]) and
                         ((aktprocsym^.definition^.rettype.def^.deftype<>
                         orddef) or (porddef(aktprocsym^.definition^.
                         rettype.def)^.typ<>bool8bit)) then
                        Message(parser_e_comparative_operator_return_boolean);
                       if assigned(opsym) then
                         opsym^.vartype.def:=aktprocsym^.definition^.rettype.def;
                       { We need to add the return type in the mangledname
                         to allow overloading with just different results !! (PM) }
                       aktprocsym^.definition^.setmangledname(
                         aktprocsym^.definition^.mangledname+'$$'+hs);
                       if (optoken=_ASSIGNMENT) and
                          is_equal(aktprocsym^.definition^.rettype.def,
                             pvarsym(aktprocsym^.definition^.parast^.symindex^.first)^.vartype.def) then
                         message(parser_e_no_such_assignment);
                     end;
                 end;
  end;
  if isclassmethod and
     assigned(aktprocsym) then
{$ifdef INCLUDEOK}
    include(aktprocsym^.definition^.procoptions,po_classmethod);
{$else}
    aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_classmethod];
{$endif}
  consume(_SEMICOLON);
  dec(lexlevel);
end;


{****************************************************************************
                        Procedure directive handlers
****************************************************************************}

{$ifdef tp}
  {$F+}
{$endif}

procedure pd_far(const procnames:Tstringcontainer);
begin
  Message(parser_w_proc_far_ignored);
end;

procedure pd_near(const procnames:Tstringcontainer);
begin
  Message(parser_w_proc_near_ignored);
end;

procedure pd_export(const procnames:Tstringcontainer);
begin
  if assigned(procinfo^._class) then
    Message(parser_e_methods_dont_be_export);
  if lexlevel<>normal_function_level then
    Message(parser_e_dont_nest_export);
  { only os/2 needs this }
  if target_info.target=target_i386_os2 then
   begin
     procnames.insert(realname);
     procinfo^.exported:=true;
     if cs_link_deffile in aktglobalswitches then
       deffile.AddExport(aktprocsym^.definition^.mangledname);
   end;
end;

procedure pd_inline(const procnames:Tstringcontainer);
begin
  if not(cs_support_inline in aktmoduleswitches) then
   Message(parser_e_proc_inline_not_supported);
end;

procedure pd_forward(const procnames:Tstringcontainer);
begin
  aktprocsym^.definition^.forwarddef:=true;
end;

procedure pd_stdcall(const procnames:Tstringcontainer);
begin
end;

procedure pd_safecall(const procnames:Tstringcontainer);
begin
end;

procedure pd_alias(const procnames:Tstringcontainer);
begin
  consume(_COLON);
  procnames.insert(get_stringconst);
end;

procedure pd_asmname(const procnames:Tstringcontainer);
begin
  aktprocsym^.definition^.setmangledname(target_os.Cprefix+pattern);
  if token=_CCHAR then
    consume(_CCHAR)
  else
    consume(_CSTRING);
  { we don't need anything else }
  aktprocsym^.definition^.forwarddef:=false;
end;

procedure pd_intern(const procnames:Tstringcontainer);
begin
  consume(_COLON);
  aktprocsym^.definition^.extnumber:=get_intconst;
end;

procedure pd_system(const procnames:Tstringcontainer);
begin
  aktprocsym^.definition^.setmangledname(realname);
end;

procedure pd_abstract(const procnames:Tstringcontainer);
begin
  if (po_virtualmethod in aktprocsym^.definition^.procoptions) then
{$ifdef INCLUDEOK}
    include(aktprocsym^.definition^.procoptions,po_abstractmethod)
{$else}
    aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_abstractmethod]
{$endif}
  else
    Message(parser_e_only_virtual_methods_abstract);
  { the method is defined }
  aktprocsym^.definition^.forwarddef:=false;
end;

procedure pd_virtual(const procnames:Tstringcontainer);
{$ifdef WITHDMT}
var
  pt : ptree;
{$endif WITHDMT}
begin
  if (aktprocsym^.definition^.proctypeoption=potype_constructor) and
     not(aktprocsym^.definition^._class^.is_class) then
    Message(parser_e_constructor_cannot_be_not_virtual);
{$ifdef WITHDMT}
  if not(aktprocsym^.definition^._class^.is_class) and
    (token<>_SEMICOLON) then
    begin
       { any type of parameter is allowed here! }

       pt:=comp_expr(true);
       do_firstpass(pt);
       if is_constintnode(pt) then
         begin
           include(aktprocsym^.definition^.procoptions,po_msgint);
           aktprocsym^.definition^.messageinf.i:=pt^.value;
         end
       else
         Message(parser_e_ill_msg_expr);
       disposetree(pt);
    end;
{$endif WITHDMT}
end;

procedure pd_static(const procnames:Tstringcontainer);
begin
  if (cs_static_keyword in aktmoduleswitches) then
    begin
{$ifdef INCLUDEOK}
      include(aktprocsym^.symoptions,sp_static);
      include(aktprocsym^.definition^.procoptions,po_staticmethod);
{$else}
      aktprocsym^.symoptions:=aktprocsym^.symoptions+[sp_static];
      aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_staticmethod];
{$endif}
    end;
end;

procedure pd_override(const procnames:Tstringcontainer);
begin
  if not(aktprocsym^.definition^._class^.is_class) then
    Message(parser_e_no_object_override);
end;

procedure pd_message(const procnames:Tstringcontainer);
var
  pt : ptree;
begin
  { check parameter type }
  if not(po_containsself in aktprocsym^.definition^.procoptions) and
     ((aktprocsym^.definition^.para^.count<>1) or
      (pparaitem(aktprocsym^.definition^.para^.first)^.paratyp<>vs_var)) then
   Message(parser_e_ill_msg_param);
  pt:=comp_expr(true);
  do_firstpass(pt);
  if pt^.treetype=stringconstn then
    begin
{$ifdef INCLUDEOK}
      include(aktprocsym^.definition^.procoptions,po_msgstr);
{$else}
      aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_msgstr];
{$endif}
      aktprocsym^.definition^.messageinf.str:=strnew(pt^.value_str);
    end
  else
   if is_constintnode(pt) then
    begin
{$ifdef INCLUDEOK}
      include(aktprocsym^.definition^.procoptions,po_msgint);
{$else}
      aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+[po_msgint];
{$endif}
      aktprocsym^.definition^.messageinf.i:=pt^.value;
    end
  else
    Message(parser_e_ill_msg_expr);
  disposetree(pt);
end;


procedure resetvaluepara(p:pnamedindexobject);{$ifndef FPC}far;{$endif}
begin
  if psym(p)^.typ=varsym then
    with pvarsym(p)^ do
       if copy(name,1,3)='val' then
          aktprocsym^.definition^.parast^.symsearch^.rename(name,copy(name,4,length(name)));
end;


procedure pd_cdecl(const procnames:Tstringcontainer);
begin
  if aktprocsym^.definition^.deftype<>procvardef then
    aktprocsym^.definition^.setmangledname(target_os.Cprefix+realname);
  { do not copy on local !! }
  if (aktprocsym^.definition^.deftype=procdef) and
     assigned(aktprocsym^.definition^.parast) then
    aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}resetvaluepara);
end;


procedure pd_pascal(const procnames:Tstringcontainer);
var st,parast : psymtable;
    lastps,ps : psym;
begin
   new(st,init(parasymtable));
   parast:=aktprocsym^.definition^.parast;
   lastps:=nil;
   while assigned(parast^.symindex^.first) and (lastps<>psym(parast^.symindex^.first)) do
     begin
       ps:=psym(parast^.symindex^.first);
       while assigned(ps^.next) and (psym(ps^.next)<>lastps) do
         ps:=psym(ps^.next);
       ps^.owner:=st;
       { recalculate the corrected offset }
       { the really_insert_in_data procedure
         for parasymtable should only calculateoffset PM }
       ps^.insert_in_data;
       { reset the owner correctly }
       ps^.owner:=parast;
       lastps:=ps;
     end;
end;


procedure pd_register(const procnames:Tstringcontainer);
begin
  Message(parser_w_proc_register_ignored);
end;


procedure pd_syscall(const procnames:Tstringcontainer);
begin
  aktprocsym^.definition^.forwarddef:=false;
  aktprocsym^.definition^.extnumber:=get_intconst;
end;


procedure pd_external(const procnames:Tstringcontainer);
{
  If import_dll=nil the procedure is assumed to be in another
  object file. In that object file it should have the name to
  which import_name is pointing to. Otherwise, the procedure is
  assumed to be in the DLL to which import_dll is pointing to. In
  that case either import_nr<>0 or import_name<>nil is true, so
  the procedure is either imported by number or by name. (DM)
}
var
  import_dll,
  import_name : string;
  import_nr   : word;
begin
  aktprocsym^.definition^.forwarddef:=false;
{ If the procedure should be imported from a DLL, a constant string follows.
  This isn't really correct, an contant string expression follows
  so we check if an semicolon follows, else a string constant have to
  follow (FK) }
  import_nr:=0;
  import_name:='';
  if not(token=_SEMICOLON) and not(idtoken=_NAME) then
    begin
      import_dll:=get_stringconst;
      if (idtoken=_NAME) then
       begin
         consume(_NAME);
         import_name:=get_stringconst;
       end;
      if (idtoken=_INDEX) then
       begin
         {After the word index follows the index number in the DLL.}
         consume(_INDEX);
         import_nr:=get_intconst;
       end;
      if (import_nr=0) and (import_name='') then
        {if (aktprocsym^.definition^.options and pocdecl)<>0 then
          import_name:=aktprocsym^.definition^.mangledname
        else
          Message(parser_w_empty_import_name);}
        { this should work both for win32 and Linux !! PM }
        import_name:=realname;
      if not(current_module^.uses_imports) then
       begin
         current_module^.uses_imports:=true;
         importlib^.preparelib(current_module^.modulename^);
       end;
      if not(m_repeat_forward in aktmodeswitches) then
        begin
          { we can only have one overloaded here ! }
          if assigned(aktprocsym^.definition^.nextoverloaded) then
            importlib^.importprocedure(aktprocsym^.definition^.nextoverloaded^.mangledname,
              import_dll,import_nr,import_name)
          else
            importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name);
        end
      else
        importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name);
    end
  else
    begin
      if (idtoken=_NAME) then
       begin
         consume(_NAME);
         import_name:=get_stringconst;
         aktprocsym^.definition^.setmangledname(import_name);
       end
      else
       begin
         { external shouldn't override the cdecl/system name }
         if not (pocall_clearstack in aktprocsym^.definition^.proccalloptions) then
           aktprocsym^.definition^.setmangledname(aktprocsym^.name);
       end;
    end;
end;

{$ifdef TP}
  {$F-}
{$endif}

{const
   namelength=15;}
type
   pd_handler=procedure(const procnames:Tstringcontainer);
   proc_dir_rec=record
     idtok     : ttoken;
     pd_flags  : longint;
     handler   : pd_handler;
     pocall    : tproccalloptions;
     pooption  : tprocoptions;
     mutexclpocall : tproccalloptions;
     mutexclpotype : tproctypeoptions;
     mutexclpo     : tprocoptions;
   end;
const
  {Should contain the number of procedure directives we support.}
  num_proc_directives=29;
  proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
   (
    (
      idtok:_ABSTRACT;
      pd_flags : pd_interface+pd_object;
      handler  : {$ifndef TP}@{$endif}pd_abstract;
      pocall   : [];
      pooption : [po_abstractmethod];
      mutexclpocall : [pocall_internproc,pocall_inline];
      mutexclpotype : [potype_constructor,potype_destructor];
      mutexclpo     : [po_exports,po_interrupt,po_external]
    ),(
      idtok:_ALIAS;
      pd_flags : pd_implemen+pd_body;
      handler  : {$ifndef TP}@{$endif}pd_alias;
      pocall   : [];
      pooption : [];
      mutexclpocall : [pocall_inline];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_ASMNAME;
      pd_flags : pd_interface+pd_implemen;
      handler  : {$ifndef TP}@{$endif}pd_asmname;
      pocall   : [pocall_cdecl,pocall_clearstack];
      pooption : [po_external];
      mutexclpocall : [pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_ASSEMBLER;
      pd_flags : pd_implemen+pd_body;
      handler  : nil;
      pocall   : [];
      pooption : [po_assembler];
      mutexclpocall : [];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_CDECL;
      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
      handler  : {$ifndef TP}@{$endif}pd_cdecl;
      pocall   : [pocall_cdecl,pocall_clearstack];
      pooption : [po_savestdregs];
      mutexclpocall : [pocall_internproc,pocall_leftright,pocall_inline];
      mutexclpotype : [];
      mutexclpo     : [po_assembler,po_external]
    ),(
      idtok:_DYNAMIC;
      pd_flags : pd_interface+pd_object;
      handler  : {$ifndef TP}@{$endif}pd_virtual;
      pocall   : [];
      pooption : [po_virtualmethod];
      mutexclpocall : [pocall_internproc,pocall_inline];
      mutexclpotype : [];
      mutexclpo     : [po_exports,po_interrupt,po_external]
    ),(
      idtok:_EXPORT;
      pd_flags : pd_body+pd_global+pd_interface+pd_implemen{??};
      handler  : {$ifndef TP}@{$endif}pd_export;
      pocall   : [];
      pooption : [po_exports];
      mutexclpocall : [pocall_internproc,pocall_inline];
      mutexclpotype : [];
      mutexclpo     : [po_external,po_interrupt]
    ),(
      idtok:_EXTERNAL;
      pd_flags : pd_implemen+pd_interface;
      handler  : {$ifndef TP}@{$endif}pd_external;
      pocall   : [];
      pooption : [po_external];
      mutexclpocall : [pocall_internproc,pocall_inline,pocall_palmossyscall];
      mutexclpotype : [];
      mutexclpo     : [po_exports,po_interrupt,po_assembler]
    ),(
      idtok:_FAR;
      pd_flags : pd_implemen+pd_body+pd_interface+pd_procvar;
      handler  : {$ifndef TP}@{$endif}pd_far;
      pocall   : [];
      pooption : [];
      mutexclpocall : [pocall_internproc,pocall_inline];
      mutexclpotype : [];
      mutexclpo     : []
    ),(
      idtok:_FORWARD;
      pd_flags : pd_implemen;
      handler  : {$ifndef TP}@{$endif}pd_forward;
      pocall   : [];
      pooption : [];
      mutexclpocall : [pocall_internproc,pocall_inline];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_INLINE;
      pd_flags : pd_implemen+pd_body;
      handler  : {$ifndef TP}@{$endif}pd_inline;
      pocall   : [pocall_inline];
      pooption : [];
      mutexclpocall : [pocall_internproc];
      mutexclpotype : [potype_constructor,potype_destructor];
      mutexclpo     : [po_exports,po_external,po_interrupt]
    ),(
      idtok:_INTERNCONST;
      pd_flags : pd_implemen+pd_body;
      handler  : {$ifndef TP}@{$endif}pd_intern;
      pocall   : [pocall_internconst];
      pooption : [];
      mutexclpocall : [];
      mutexclpotype : [potype_operator];
      mutexclpo     : []
    ),(
      idtok:_INTERNPROC;
      pd_flags : pd_implemen;
      handler  : {$ifndef TP}@{$endif}pd_intern;
      pocall   : [pocall_internproc];
      pooption : [];
      mutexclpocall : [pocall_inline,pocall_clearstack,pocall_leftright,pocall_cdecl];
      mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
      mutexclpo     : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck]
    ),(
      idtok:_INTERRUPT;
      pd_flags : pd_implemen+pd_body;
      handler  : nil;
      pocall   : [];
      pooption : [po_interrupt];
      mutexclpocall : [pocall_internproc,pocall_cdecl,pocall_clearstack,pocall_leftright,pocall_inline];
      mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
      mutexclpo     : [po_external]
    ),(
      idtok:_IOCHECK;
      pd_flags : pd_implemen+pd_body;
      handler  : nil;
      pocall   : [];
      pooption : [po_iocheck];
      mutexclpocall : [pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_MESSAGE;
      pd_flags : pd_interface+pd_object;
      handler  : {$ifndef TP}@{$endif}pd_message;
      pocall   : [];
      pooption : []; { can be po_msgstr or po_msgint }
      mutexclpocall : [pocall_inline,pocall_internproc];
      mutexclpotype : [potype_constructor,potype_destructor,potype_operator];
      mutexclpo     : [po_interrupt,po_external]
    ),(
      idtok:_NEAR;
      pd_flags : pd_implemen+pd_body+pd_procvar;
      handler  : {$ifndef TP}@{$endif}pd_near;
      pocall   : [];
      pooption : [];
      mutexclpocall : [pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : []
    ),(
      idtok:_OVERRIDE;
      pd_flags : pd_interface+pd_object;
      handler  : {$ifndef TP}@{$endif}pd_override;
      pocall   : [];
      pooption : [po_overridingmethod,po_virtualmethod];
      mutexclpocall : [pocall_inline,pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_exports,po_external,po_interrupt]
    ),(
      idtok:_PASCAL;
      pd_flags : pd_implemen+pd_body+pd_procvar;
      handler  : {$ifndef TP}@{$endif}pd_pascal;
      pocall   : [pocall_leftright];
      pooption : [];
      mutexclpocall : [pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_POPSTACK;
      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
      handler  : nil;
      pocall   : [pocall_clearstack];
      pooption : [];
      mutexclpocall : [pocall_inline,pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_assembler,po_external]
    ),(
      idtok:_PUBLIC;
      pd_flags : pd_implemen+pd_body+pd_global+pd_notobject;
      handler  : nil;
      pocall   : [];
      pooption : [];
      mutexclpocall : [pocall_internproc,pocall_inline];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_REGISTER;
      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
      handler  : {$ifndef TP}@{$endif}pd_register;
      pocall   : [pocall_register];
      pooption : [];
      mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_SAFECALL;
      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
      handler  : {$ifndef TP}@{$endif}pd_safecall;
      pocall   : [pocall_safecall];
      pooption : [po_savestdregs];
      mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_internproc,pocall_inline];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_SAVEREGISTERS;
      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
      handler  : nil;
      pocall   : [];
      pooption : [po_saveregisters];
      mutexclpocall : [pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_STATIC;
      pd_flags : pd_interface+pd_object;
      handler  : {$ifndef TP}@{$endif}pd_static;
      pocall   : [];
      pooption : [po_staticmethod];
      mutexclpocall : [pocall_inline,pocall_internproc];
      mutexclpotype : [potype_constructor,potype_destructor];
      mutexclpo     : [po_external,po_interrupt,po_exports]
    ),(
      idtok:_STDCALL;
      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
      handler  : {$ifndef TP}@{$endif}pd_stdcall;
      pocall   : [pocall_stdcall];
      pooption : [po_savestdregs];
      mutexclpocall : [pocall_leftright,pocall_cdecl,pocall_inline,pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_external]
    ),(
      idtok:_SYSCALL;
      pd_flags : pd_interface;
      handler  : {$ifndef TP}@{$endif}pd_syscall;
      pocall   : [pocall_palmossyscall];
      pooption : [];
      mutexclpocall : [pocall_cdecl,pocall_inline,pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_external,po_assembler,po_interrupt,po_exports]
    ),(
      idtok:_SYSTEM;
      pd_flags : pd_implemen;
      handler  : {$ifndef TP}@{$endif}pd_system;
      pocall   : [pocall_clearstack];
      pooption : [];
      mutexclpocall : [pocall_leftright,pocall_inline,pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_external,po_assembler,po_interrupt]
    ),(
      idtok:_VIRTUAL;
      pd_flags : pd_interface+pd_object;
      handler  : {$ifndef TP}@{$endif}pd_virtual;
      pocall   : [];
      pooption : [po_virtualmethod];
      mutexclpocall : [pocall_inline,pocall_internproc];
      mutexclpotype : [];
      mutexclpo     : [po_external,po_interrupt,po_exports]
    )
   );


function is_proc_directive(tok:ttoken):boolean;
var
  i : longint;
begin
  is_proc_directive:=false;
  for i:=1 to num_proc_directives do
   if proc_direcdata[i].idtok=idtoken then
    begin
      is_proc_directive:=true;
      exit;
    end;
end;


function parse_proc_direc(const proc_names:Tstringcontainer;var pdflags:word):boolean;
{
  Parse the procedure directive, returns true if a correct directive is found
}
var
  p     : longint;
  found : boolean;
  name  : string;
begin
  parse_proc_direc:=false;
  name:=pattern;
  found:=false;
  for p:=1 to num_proc_directives do
   if proc_direcdata[p].idtok=idtoken then
    begin
      found:=true;
      break;
    end;

{ Check if the procedure directive is known }
  if not found then
   begin
      { parsing a procvar type the name can be any
        next variable !! }
      if (pdflags and (pd_procvar or pd_object))=0 then
        Message1(parser_w_unknown_proc_directive_ignored,name);
      exit;
   end;

  { static needs a special treatment }
  if (idtoken=_STATIC) and not (cs_static_keyword in aktmoduleswitches) then
    exit;

{ Conflicts between directives ? }
  if (aktprocsym^.definition^.proctypeoption in proc_direcdata[p].mutexclpotype) or
     ((aktprocsym^.definition^.proccalloptions*proc_direcdata[p].mutexclpocall)<>[]) or
     ((aktprocsym^.definition^.procoptions*proc_direcdata[p].mutexclpo)<>[]) then
   begin
     Message1(parser_e_proc_dir_conflict,name);
     exit;
   end;

{ Check if the directive is only for objects }
  if ((proc_direcdata[p].pd_flags and pd_object)<>0) and
     not assigned(aktprocsym^.definition^._class) then
    begin
      exit;
    end;
{ check if method and directive not for object public }
  if ((proc_direcdata[p].pd_flags and pd_notobject)<>0) and
     assigned(aktprocsym^.definition^._class) then
    begin
      exit;
    end;

{ consume directive, and turn flag on }
  consume(token);
  parse_proc_direc:=true;

{ Check the pd_flags if the directive should be allowed }
  if ((pdflags and pd_interface)<>0) and
     ((proc_direcdata[p].pd_flags and pd_interface)=0) then
    begin
      Message1(parser_e_proc_dir_not_allowed_in_interface,name);
      exit;
    end;
  if ((pdflags and pd_implemen)<>0) and
     ((proc_direcdata[p].pd_flags and pd_implemen)=0) then
    begin
      Message1(parser_e_proc_dir_not_allowed_in_implementation,name);
      exit;
    end;
  if ((pdflags and pd_procvar)<>0) and
     ((proc_direcdata[p].pd_flags and pd_procvar)=0) then
    begin
      Message1(parser_e_proc_dir_not_allowed_in_procvar,name);
      exit;
    end;

{ Return the new pd_flags }
  if (proc_direcdata[p].pd_flags and pd_body)=0 then
    pdflags:=pdflags and (not pd_body);
  if (proc_direcdata[p].pd_flags and pd_global)<>0 then
    pdflags:=pdflags or pd_global;

{ Add the correct flag }
  aktprocsym^.definition^.proccalloptions:=aktprocsym^.definition^.proccalloptions+proc_direcdata[p].pocall;
  aktprocsym^.definition^.procoptions:=aktprocsym^.definition^.procoptions+proc_direcdata[p].pooption;

 { Adjust positions of args for cdecl or stdcall }
   if (aktprocsym^.definition^.deftype=procdef) and
      (([pocall_cdecl,pocall_stdcall]*aktprocsym^.definition^.proccalloptions)<>[]) then
     aktprocsym^.definition^.parast^.set_alignment(target_os.size_of_longint);

{ Call the handler }
  if pointer({$ifndef FPC}@{$endif}proc_direcdata[p].handler)<>nil then
    proc_direcdata[p].handler(proc_names);
end;

{***************************************************************************}

function check_identical(var p : pprocdef) : boolean;
{
  Search for idendical definitions,
  if there is a forward, then kill this.

  Returns the result of the forward check.

  Removed from unter_dec to keep the source readable
}
var
  hd,pd : Pprocdef;
  storeparast : psymtable;
  ad,fd : psym;
  s : string;
begin
  check_identical:=false;
  p:=nil;
  pd:=aktprocsym^.definition;
  if assigned(pd) then
   begin
   { Is there an overload/forward ? }
     if assigned(pd^.nextoverloaded) then
      begin
      { walk the procdef list }
        while (assigned(pd)) and (assigned(pd^.nextoverloaded)) do
         begin
           if (not(m_repeat_forward in aktmodeswitches) and
               (aktprocsym^.definition^.para^.count=0)) or
              (equal_paras(aktprocsym^.definition^.para,pd^.nextoverloaded^.para,false) and
              { for operators equal_paras is not enough !! }
              ((aktprocsym^.definition^.proctypeoption<>potype_operator) or (optoken<>_ASSIGNMENT) or
               is_equal(pd^.nextoverloaded^.rettype.def,aktprocsym^.definition^.rettype.def))) then
             begin
               if pd^.nextoverloaded^.forwarddef then
               { remove the forward definition  but don't delete it,      }
               { the symtable is the owner !!  }
                 begin
                   hd:=pd^.nextoverloaded;
                 { Check if the procedure type and return type are correct }
                   if (hd^.proctypeoption<>aktprocsym^.definition^.proctypeoption) or
                      (not(is_equal(hd^.rettype.def,aktprocsym^.definition^.rettype.def)) and
                      (m_repeat_forward in aktmodeswitches)) then
                     begin
                       Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName);
                       exit;
                     end;
                 { Check calling convention, no check for internconst,internproc which
                   are only defined in interface or implementation }
                   if (hd^.proccalloptions-[pocall_internconst,pocall_internproc]<>
                       aktprocsym^.definition^.proccalloptions-[pocall_internconst,pocall_internproc]) then
                    begin
                      { only trigger an error, becuase it doesn't hurt }
                      Message(parser_e_call_convention_dont_match_forward);
                      { set the mangledname to the interface name so it doesn't trigger
                        the Note about different manglednames (PFV) }
                      aktprocsym^.definition^.setmangledname(hd^.mangledname);
                    end;
                 { manglednames are equal? }
                   hd^.count:=false;
                   if (m_repeat_forward in aktmodeswitches) or
                      aktprocsym^.definition^.haspara then
                    begin
                      if (hd^.mangledname<>aktprocsym^.definition^.mangledname) then
                       begin
                         { When overloading is not possible then we issue an error }
                         { This is not true, tp7/delphi don't give an error when a renamed
                           type is used in the other declaration (PFV)
                           if not(m_repeat_forward in aktmodeswitches) then
                          begin
                            Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName);
                            exit;
                          end; }

                         if not(po_external in aktprocsym^.definition^.procoptions) then
                           Message2(parser_n_interface_name_diff_implementation_name,hd^.mangledname,
                             aktprocsym^.definition^.mangledname);
                       { reset the mangledname of the interface part to be sure }
                       { this is wrong because the mangled name might have been used already !! }
                          if hd^.is_used then
                            renameasmsymbol(hd^.mangledname,aktprocsym^.definition^.mangledname);
                          hd^.setmangledname(aktprocsym^.definition^.mangledname);
                       { so we need to keep the name of interface !!
                         No!!!! The procedure directives can change the mangledname.
                         I fixed this by first calling check_identical and then doing
                         the proc directives, but this is not a good solution.(DM)}
                         { this is also wrong (PM)
                         aktprocsym^.definition^.setmangledname(hd^.mangledname);}
                       end
                      else
                       begin
                       { If mangled names are equal, therefore    }
                       { they have the same number of parameters  }
                       { Therefore we can check the name of these }
                       { parameters...                      }
                         if hd^.forwarddef and aktprocsym^.definition^.forwarddef then
                           begin
                             Message1(parser_e_function_already_declared_public_forward,aktprocsym^.demangledName);
                             Check_identical:=true;
                           { Remove other forward from the list to reduce errors }
                             pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
                             exit;
                           end;
                         ad:=psym(hd^.parast^.symindex^.first);
                         fd:=psym(aktprocsym^.definition^.parast^.symindex^.first);
                         if assigned(ad) and assigned(fd) then
                           begin
                             while assigned(ad) and assigned(fd) do
                               begin
                                 s:=ad^.name;
                                 if s<>fd^.name then
                                   begin
                                     Message3(parser_e_header_different_var_names,
                                       aktprocsym^.name,s,fd^.name);
                                     break;
                                   end;
                               { it is impossible to have a nil pointer }
                               { for only one parameter - since they    }
                               { have the same number of parameters.    }
                               { Left = next parameter.          }
                                 ad:=psym(ad^.left);
                                 fd:=psym(fd^.left);
                               end;
                           end;
                       end;
                    end;
                 { also the para_offset }
                   hd^.parast^.address_fixup:=aktprocsym^.definition^.parast^.address_fixup;
                   hd^.count:=true;

                 { remove pd^.nextoverloaded from the list }
                 { and add aktprocsym^.definition }
                   pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
                   hd^.nextoverloaded:=aktprocsym^.definition^.nextoverloaded;
                 { Alert! All fields of aktprocsym^.definition that are modified
                   by the procdir handlers must be copied here!.}
                   hd^.forwarddef:=false;
                   hd^.proccalloptions:=hd^.proccalloptions + aktprocsym^.definition^.proccalloptions;
                   hd^.procoptions:=hd^.procoptions + aktprocsym^.definition^.procoptions;
                   if aktprocsym^.definition^.extnumber=-1 then
                     aktprocsym^.definition^.extnumber:=hd^.extnumber
                   else
                     if hd^.extnumber=-1 then
                       hd^.extnumber:=aktprocsym^.definition^.extnumber;
                   { switch parast for warning in implementation  PM }
                   if (m_repeat_forward in aktmodeswitches) or
                      aktprocsym^.definition^.haspara then
                     begin
                        storeparast:=hd^.parast;
                        hd^.parast:=aktprocsym^.definition^.parast;
                        aktprocsym^.definition^.parast:=storeparast;
                     end;
                   if pd=aktprocsym^.definition then
                     p:=nil
                   else
                     p:=pd;
                   aktprocsym^.definition:=hd;
                   check_identical:=true;
                 end
               else
               { abstract methods aren't forward defined, but this }
               { needs another error message                   }
                 if not(po_abstractmethod in pd^.nextoverloaded^.procoptions) then
                   Message(parser_e_overloaded_have_same_parameters)
                 else
                   Message(parser_e_abstract_no_definition);
               break;
             end;
           pd:=pd^.nextoverloaded;
         end;
      end
     else
      begin
      { there is no overloaded, so its always identical with itself }
        check_identical:=true;
      end;
   end;
{ insert opsym only in the right symtable }
  if ((procinfo^.flags and pi_operator)<>0) and assigned(opsym)
     and not parse_only then
    begin
      if ret_in_param(aktprocsym^.definition^.rettype.def) then
        begin
          pprocdef(aktprocsym^.definition)^.parast^.insert(opsym);
        { this increases the data size }
        { correct this to get the right ret $value }
          dec(pprocdef(aktprocsym^.definition)^.parast^.datasize,opsym^.getpushsize);
          { this allows to read the funcretoffset }
          opsym^.address:=-4;
          opsym^.varspez:=vs_var;
        end
      else
        pprocdef(aktprocsym^.definition)^.localst^.insert(opsym);
    end;
end;

procedure compile_proc_body(const proc_names:Tstringcontainer;
                            make_global,parent_has_class:boolean);
{
  Compile the body of a procedure
}
var
   oldexitlabel,oldexit2label : pasmlabel;
   oldfaillabel,oldquickexitlabel:Pasmlabel;
   _class,hp:Pobjectdef;
   { switches can change inside the procedure }
   entryswitches, exitswitches : tlocalswitches;
   oldaktmaxfpuregisters,localmaxfpuregisters : longint;
   { code for the subroutine as tree }
{$ifdef newcg}
   code:ptree;
{$else newcg}
   code:ptree;
{$endif newcg}
   { size of the local strackframe }
   stackframe:longint;
   { true when no stackframe is required }
   nostackframe:boolean;
   { number of bytes which have to be cleared by RET }
   parasize:longint;
   { filepositions }
   entrypos,
   savepos,
   exitpos   : tfileposinfo;
begin
   { calculate the lexical level }
   inc(lexlevel);
   if lexlevel>32 then
    Message(parser_e_too_much_lexlevel);

   { static is also important for local procedures !! }
   if (po_staticmethod in aktprocsym^.definition^.procoptions) then
     allow_only_static:=true
   else if (lexlevel=normal_function_level) then
     allow_only_static:=false;

   { save old labels }
   oldexitlabel:=aktexitlabel;
   oldexit2label:=aktexit2label;
   oldquickexitlabel:=quickexitlabel;
   oldfaillabel:=faillabel;
   { get new labels }
   getlabel(aktexitlabel);
   getlabel(aktexit2label);
   { exit for fail in constructors }
   if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
     begin
       getlabel(faillabel);
       getlabel(quickexitlabel);
     end;
   { reset break and continue labels }
   block_type:=bt_general;
   aktbreaklabel:=nil;
   aktcontinuelabel:=nil;

   { insert symtables for the class, by only if it is no nested function }
   if assigned(procinfo^._class) and not(parent_has_class) then
     begin
       { insert them in the reverse order ! }
       hp:=nil;
       repeat
         _class:=procinfo^._class;
         while _class^.childof<>hp do
           _class:=_class^.childof;
         hp:=_class;
         _class^.symtable^.next:=symtablestack;
         symtablestack:=_class^.symtable;
       until hp=procinfo^._class;
     end;

   { insert parasymtable in symtablestack}
   { only if lexlevel > 1 !!! global symtable should be right after staticsymtazble
     for checking of same names used in interface and implementation !! }
   if lexlevel>=normal_function_level then
     begin
        aktprocsym^.definition^.parast^.next:=symtablestack;
        symtablestack:=aktprocsym^.definition^.parast;
        symtablestack^.symtablelevel:=lexlevel;
     end;
   { insert localsymtable in symtablestack}
   aktprocsym^.definition^.localst^.next:=symtablestack;
   symtablestack:=aktprocsym^.definition^.localst;
   symtablestack^.symtablelevel:=lexlevel;
   { constant symbols are inserted in this symboltable }
   constsymtable:=symtablestack;

   { reset the temporary memory }
   cleartempgen;

{$ifdef newcg}
   tg.usedinproc:=[];
{$else newcg}
   { no registers are used }
   usedinproc:=0;
{$endif newcg}
   { save entry info }
   entrypos:=aktfilepos;
   entryswitches:=aktlocalswitches;
   localmaxfpuregisters:=aktmaxfpuregisters;
{$ifdef newcg}
{$ifdef dummy}
   { parse the code ... }
   if (po_assembler in aktprocsym^.definition^.procoptions) then
     code:=convtree2node(assembler_block)
   else
     code:=convtree2node(block(current_module^.islibrary));
{$endif dummy}
   { parse the code ... }
   if (po_assembler in aktprocsym^.definition^.procoptions) then
     code:=assembler_block
   else
     code:=block(current_module^.islibrary);
{$else newcg}
   { parse the code ... }
   if (po_assembler in aktprocsym^.definition^.procoptions) then
     code:=assembler_block
   else
     code:=block(current_module^.islibrary);
{$endif newcg}

   { get a better entry point }
   if assigned(code) then
     entrypos:=code^.fileinfo;

   { save exit info }
   exitswitches:=aktlocalswitches;
   exitpos:=last_endtoken_filepos;

   { save current filepos }
   savepos:=aktfilepos;

   {When we are called to compile the body of a unit, aktprocsym should
    point to the unit initialization. If the unit has no initialization,
    aktprocsym=nil. But in that case code=nil. hus we should check for
    code=nil, when we use aktprocsym.}

   { set the framepointer to esp for assembler functions }
   { but only if the are no local variables           }
   { already done in assembler_block }
{$ifdef newcg}
   tg.setfirsttemp(procinfo^.firsttemp_offset);
{$else newcg}
   setfirsttemp(procinfo^.firsttemp_offset);
{$endif newcg}

   { ... and generate assembler }
   { but set the right switches for entry !! }
   aktlocalswitches:=entryswitches;
   oldaktmaxfpuregisters:=aktmaxfpuregisters;
   aktmaxfpuregisters:=localmaxfpuregisters;
{$ifndef NOPASS2}
{$ifdef newcg}
   if assigned(code) then
     generatecode(code);
{$else newcg}
   if assigned(code) then
     generatecode(code);
{$endif newcg}
   { set switches to status at end of procedure }
   aktlocalswitches:=exitswitches;

   if assigned(code) then
     begin
        aktprocsym^.definition^.code:=code;

        { the procedure is now defined }
        aktprocsym^.definition^.forwarddef:=false;
{$ifdef newcg}
        aktprocsym^.definition^.usedregisters:=tg.usedinproc;
{$else newcg}
        aktprocsym^.definition^.usedregisters:=usedinproc;
{$endif newcg}
     end;

{$ifdef newcg}
   stackframe:=tg.gettempsize;
{$else newcg}
   stackframe:=gettempsize;
{$endif newcg}

   { first generate entry code with the correct position and switches }
   aktfilepos:=entrypos;
   aktlocalswitches:=entryswitches;
{$ifdef newcg}
   if assigned(code) then
     cg^.g_entrycode(procinfo^.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
{$else newcg}
   if assigned(code) then
     genentrycode(procinfo^.aktentrycode,proc_names,make_global,stackframe,parasize,nostackframe,false);
{$endif newcg}

   { now generate exit code with the correct position and switches }
   aktfilepos:=exitpos;
   aktlocalswitches:=exitswitches;
   if assigned(code) then
     begin
{$ifdef newcg}
       cg^.g_exitcode(procinfo^.aktexitcode,parasize,nostackframe,false);
{$else newcg}
       genexitcode(procinfo^.aktexitcode,parasize,nostackframe,false);
{$endif newcg}
       procinfo^.aktproccode^.insertlist(procinfo^.aktentrycode);
       procinfo^.aktproccode^.concatlist(procinfo^.aktexitcode);
{$ifdef i386}
 {$ifndef NoOpt}
       if (cs_optimize in aktglobalswitches) and
       { do not optimize pure assembler procedures }
         ((procinfo^.flags and pi_is_assembler)=0)  then
           Optimize(procinfo^.aktproccode);
 {$endif NoOpt}
{$endif}
       { save local data (casetable) also in the same file }
       if assigned(procinfo^.aktlocaldata) and
          (not procinfo^.aktlocaldata^.empty) then
         begin
            procinfo^.aktproccode^.concat(new(pai_section,init(sec_data)));
            procinfo^.aktproccode^.concatlist(procinfo^.aktlocaldata);
            procinfo^.aktproccode^.concat(new(pai_section,init(sec_code)));
         end;
       { now we can insert a cut }
       if (cs_create_smart in aktmoduleswitches) then
         codesegment^.concat(new(pai_cut,init));

       { add the procedure to the codesegment }
       codesegment^.concatlist(procinfo^.aktproccode);
     end;
{$else}
   if assigned(code) then
    firstpass(code);
{$endif NOPASS2}

   { ... remove symbol tables, for the browser leave the static table }
{    if (cs_browser in aktmoduleswitches) and (symtablestack^.symtabletype=staticsymtable) then
    symtablestack^.next:=symtablestack^.next^.next
   else }
   if lexlevel>=normal_function_level then
     symtablestack:=symtablestack^.next^.next
   else
     symtablestack:=symtablestack^.next;

   { ... check for unused symbols      }
   { but only if there is no asm block }
   if assigned(code) then
     begin
       if (Errorcount=0) then
         begin
           aktprocsym^.definition^.localst^.check_forwards;
           aktprocsym^.definition^.localst^.checklabels;
         end;
       if (procinfo^.flags and pi_uses_asm)=0 then
         begin
            { not for unit init, becuase the var can be used in finalize,
              it will be done in proc_unit }
            if not(aktprocsym^.definition^.proctypeoption
               in [potype_proginit,potype_unitinit,potype_unitfinalize]) then
               aktprocsym^.definition^.localst^.allsymbolsused;
            aktprocsym^.definition^.parast^.allsymbolsused;
         end;
     end;

   { the local symtables can be deleted, but the parast   }
   { doesn't, (checking definitons when calling a        }
   { function                                        }
   { not for a inline procedure !!               (PM)   }
   { at lexlevel = 1 localst is the staticsymtable itself }
   { so no dispose here !!                              }
   if assigned(code) and
      not(cs_browser in aktmoduleswitches) and
      not(pocall_inline in aktprocsym^.definition^.proccalloptions) then
     begin
       if lexlevel>=normal_function_level then
         dispose(aktprocsym^.definition^.localst,done);
       aktprocsym^.definition^.localst:=nil;
     end;

{$ifdef newcg}
   { all registers can be used again }
   tg.resetusableregisters;
   { only now we can remove the temps }
   tg.resettempgen;
{$else newcg}
   { all registers can be used again }
   resetusableregisters;
   { only now we can remove the temps }
   resettempgen;
{$endif newcg}

   { remove code tree, if not inline procedure }
   if assigned(code) and not(pocall_inline in aktprocsym^.definition^.proccalloptions) then
{$ifdef newcg}
     {!!!!!!! dispose(code,done); }
     disposetree(code);
{$else newcg}
     disposetree(code);
{$endif newcg}

   { remove class member symbol tables }
   while symtablestack^.symtabletype=objectsymtable do
     symtablestack:=symtablestack^.next;

   aktmaxfpuregisters:=oldaktmaxfpuregisters;

   { restore filepos, the switches are already set }
   aktfilepos:=savepos;
   { restore labels }
   aktexitlabel:=oldexitlabel;
   aktexit2label:=oldexit2label;
   quickexitlabel:=oldquickexitlabel;
   faillabel:=oldfaillabel;

   { reset to normal non static function }
   if (lexlevel=normal_function_level) then
     allow_only_static:=false;
   { previous lexlevel }
   dec(lexlevel);
end;


procedure parse_proc_directives(Anames:Pstringcontainer;var pdflags:word);
{
  Parse the procedure directives. It does not matter if procedure directives
  are written using ;procdir; or ['procdir'] syntax.
}
var
  res : boolean;
begin
  while token in [_ID,_LECKKLAMMER] do
   begin
     if try_to_consume(_LECKKLAMMER) then
      begin
        repeat
          parse_proc_direc(Anames^,pdflags);
        until not try_to_consume(_COMMA);
        consume(_RECKKLAMMER);
        { we always expect at least '[];' }
        res:=true;
      end
     else
      res:=parse_proc_direc(Anames^,pdflags);
   { A procedure directive normally followed by a semicolon, but in
     a const section we should stop when _EQUAL is found }
     if res then
      begin
        if (block_type=bt_const) and
           (token=_EQUAL) then
         break;
        consume(_SEMICOLON);
      end
     else
      break;
   end;
end;

procedure parse_var_proc_directives(var sym : psym);
var
  anames  : pstringcontainer;
  pdflags : word;
  oldsym  : pprocsym;
  pd      : pabstractprocdef;
begin
  oldsym:=aktprocsym;
  anames:=new(pstringcontainer,init);
  pdflags:=pd_procvar;
  { we create a temporary aktprocsym to read the directives }
  aktprocsym:=new(pprocsym,init(sym^.name));
  case sym^.typ of
    varsym :
      pd:=pabstractprocdef(pvarsym(sym)^.vartype.def);
    typedconstsym :
      pd:=pabstractprocdef(ptypedconstsym(sym)^.typedconsttype.def);
    typesym :
      pd:=pabstractprocdef(ptypesym(sym)^.restype.def);
    else
      internalerror(994932432);
  end;
  if pd^.deftype<>procvardef then
   internalerror(994932433);
  pabstractprocdef(aktprocsym^.definition):=pd;
  { names should never be used anyway }
  inc(lexlevel);
  parse_proc_directives(anames,pdflags);
  dec(lexlevel);
  aktprocsym^.definition:=nil;
  dispose(aktprocsym,done);
  dispose(anames,done);
  aktprocsym:=oldsym;
end;

procedure parse_object_proc_directives(var sym : pprocsym);
var
  anames : pstringcontainer;
  pdflags : word;
begin
  pdflags:=pd_object;
  anames:=new(pstringcontainer,init);
  inc(lexlevel);
  parse_proc_directives(anames,pdflags);
  dec(lexlevel);
  dispose(anames,done);
  if (po_containsself in aktprocsym^.definition^.procoptions) and
     (([po_msgstr,po_msgint]*aktprocsym^.definition^.procoptions)=[]) then
    Message(parser_e_self_in_non_message_handler);
end;

procedure checkvaluepara(p:pnamedindexobject);{$ifndef FPC}far;{$endif}
var
  vs : pvarsym;
  s  : string;
begin
  with pvarsym(p)^ do
   begin
     if copy(name,1,3)='val' then
      begin
        s:=Copy(name,4,255);
        if not(po_assembler in aktprocsym^.definition^.procoptions) then
         begin
           vs:=new(Pvarsym,initdef(s,vartype.def));
           vs^.fileinfo:=fileinfo;
           vs^.varspez:=varspez;
           aktprocsym^.definition^.localst^.insert(vs);
{$ifdef INCLUDEOK}
           include(vs^.varoptions,vo_is_local_copy);
{$else}
           vs^.varoptions:=vs^.varoptions+[vo_is_local_copy];
{$endif}
           vs^.varstate:=vs_assigned;
           localvarsym:=vs;
           inc(refs); { the para was used to set the local copy ! }
           { warnings only on local copy ! }
           varstate:=vs_used;
         end
        else
         begin
           aktprocsym^.definition^.parast^.rename(name,s);
         end;
      end;
   end;
end;


procedure read_proc;
{
  Parses the procedure directives, then parses the procedure body, then
  generates the code for it
}
var
  oldprefix     : string;
  oldprocsym       : Pprocsym;
  oldprocinfo      : pprocinfo;
  oldconstsymtable : Psymtable;
  oldfilepos       : tfileposinfo;
  names           : Pstringcontainer;
  pdflags         : word;
  prevdef,stdef   : pprocdef;
begin
{ save old state }
   oldprocsym:=aktprocsym;
   oldprefix:=procprefix;
   oldconstsymtable:=constsymtable;
   oldprocinfo:=procinfo;
{ create a new procedure }
   new(names,init);
{$ifdef fixLeaksOnError}
   strContStack.push(names);
{$endif fixLeaksOnError}
   codegen_newprocedure;
   with procinfo^ do
    begin
      parent:=oldprocinfo;
    { clear flags }
      flags:=0;
    { standard frame pointer }
      framepointer:=frame_pointer;
      { funcret_is_valid:=false; }
      funcret_state:=vs_declared;
    { is this a nested function of a method ? }
      if assigned(oldprocinfo) then
        _class:=oldprocinfo^._class;
    end;

   parse_proc_dec;

   procinfo^.sym:=aktprocsym;
   procinfo^.def:=aktprocsym^.definition;

{ set the default function options }
   if parse_only then
    begin
      aktprocsym^.definition^.forwarddef:=true;
      { set also the interface flag, for better error message when the
        implementation doesn't much this header }
      aktprocsym^.definition^.interfacedef:=true;
      pdflags:=pd_interface;
    end
   else
    begin
      pdflags:=pd_body;
      if current_module^.in_implementation then
       pdflags:=pdflags or pd_implemen;
      if (not current_module^.is_unit) or (cs_create_smart in aktmoduleswitches) then
       pdflags:=pdflags or pd_global;
      procinfo^.exported:=false;
      aktprocsym^.definition^.forwarddef:=false;
    end;

{ parse the directives that may follow }
   inc(lexlevel);
   parse_proc_directives(names,pdflags);
   dec(lexlevel);

{ set aktfilepos to the beginning of the function declaration }
   oldfilepos:=aktfilepos;
   aktfilepos:=aktprocsym^.definition^.fileinfo;

{ search for forward declarations }
   if not check_identical(prevdef) then
     begin
     { A method must be forward defined (in the object declaration) }
       if assigned(procinfo^._class) and (not assigned(oldprocinfo^._class)) then
         Message(parser_e_header_dont_match_any_member);
     { Give a better error if there is a forward def in the interface and only
       a single implementation }
       if (not aktprocsym^.definition^.forwarddef) and
          assigned(aktprocsym^.definition^.nextoverloaded) and
          aktprocsym^.definition^.nextoverloaded^.forwarddef and
          aktprocsym^.definition^.nextoverloaded^.interfacedef and
          not(assigned(aktprocsym^.definition^.nextoverloaded^.nextoverloaded)) then
         Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName)
       else
        begin
        { check the global flag }
          if (procinfo^.flags and pi_is_global)<>0 then
            Message(parser_e_overloaded_must_be_all_global);
        end
     end;

{ set return type here, becuase the aktprocsym^.definition can be
  changed by check_identical (PFV) }
   procinfo^.returntype.def:=aktprocsym^.definition^.rettype.def;

   { pointer to the return value ? }
   if ret_in_param(procinfo^.returntype.def) then
    begin
      procinfo^.return_offset:=procinfo^.para_offset;
      inc(procinfo^.para_offset,target_os.size_of_pointer);
    end;
   { allows to access the parameters of main functions in nested functions }
   aktprocsym^.definition^.parast^.address_fixup:=procinfo^.para_offset;

   { when it is a value para and it needs a local copy then rename
     the parameter and insert a copy in the localst. This is not done
     for assembler procedures }
   if (not parse_only) and (not aktprocsym^.definition^.forwarddef) then
     aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}checkvaluepara);

{ restore file pos }
   aktfilepos:=oldfilepos;

{ compile procedure when a body is needed }
   if (pdflags and pd_body)<>0 then
     begin
       Message1(parser_p_procedure_start,aktprocsym^.demangledname);
       names^.insert(aktprocsym^.definition^.mangledname);
      { set _FAIL as keyword if constructor }
      if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
        tokeninfo^[_FAIL].keyword:=m_all;
      if assigned(aktprocsym^.definition^._class) then
        tokeninfo^[_SELF].keyword:=m_all;

       compile_proc_body(names^,((pdflags and pd_global)<>0),assigned(oldprocinfo^._class));

      { reset _FAIL as normal }
      if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
        tokeninfo^[_FAIL].keyword:=m_none;
      if assigned(aktprocsym^.definition^._class) and (lexlevel=main_program_level) then
        tokeninfo^[_SELF].keyword:=m_none;
       consume(_SEMICOLON);
     end;
{ close }
{$ifdef fixLeaksOnError}
   if names <> strContStack.pop then
     writeln('problem with strContStack in psub!');
{$endif fixLeaksOnError}
   dispose(names,done);
   codegen_doneprocedure;
{ Restore old state }
   constsymtable:=oldconstsymtable;
   { from now on all refernece to mangledname means
     that the function is already used }
   aktprocsym^.definition^.count:=true;
   { restore the interface order to maintain CRC values PM }
   if assigned(prevdef) and assigned(aktprocsym^.definition^.nextoverloaded) then
     begin
       stdef:=aktprocsym^.definition;
       aktprocsym^.definition:=stdef^.nextoverloaded;
       stdef^.nextoverloaded:=prevdef^.nextoverloaded;
       prevdef^.nextoverloaded:=stdef;
     end;
   aktprocsym:=oldprocsym;
   procprefix:=oldprefix;
   procinfo:=oldprocinfo;
   opsym:=nil;
end;

end.

{
  $Log$
  Revision 1.58  2000-04-25 23:55:29  pierre
    + Hint about unused unit
    * Testop bug fixed !!
      Now the operators are only applied if the unit is explicitly loaded

  Revision 1.57  2000/04/24 12:48:37  peter
    * removed unused vars

  Revision 1.56  2000/03/31 22:56:47  pierre
    * fix the handling of value parameters in cdecl function

  Revision 1.55  2000/03/27 11:57:22  pierre
   * fix for bug 890

  Revision 1.54  2000/03/23 22:17:51  pierre
   * fix tf000008 bug

  Revision 1.53  2000/03/16 16:41:13  pierre
   * fix for bug 807

  Revision 1.52  2000/03/15 23:10:00  pierre
    * fix for bug 848 (that still genrated wrong code)
    + better testing for variables used in assembler
      (gives an error if variable is not directly reachable !)

  Revision 1.51  2000/02/27 14:44:39  peter
    * if calling convention doesn't match don't print note about
      different manglednames

  Revision 1.50  2000/02/20 20:49:45  florian
    * newcg is compiling
    * fixed the dup id problem reported by Paul Y.

  Revision 1.49  2000/02/17 14:53:42  florian
    * some updates for the newcg

  Revision 1.48  2000/02/09 13:23:00  peter
    * log truncated

  Revision 1.47  2000/02/08 13:55:13  peter
    * reset section back to code after localdata

  Revision 1.46  2000/02/04 20:00:22  florian
    * an exception in a construcor calls now the destructor (this applies only
      to classes)

  Revision 1.45  2000/02/04 14:54:17  jonas
    * moved call to resetusableregs to compile_proc_body (put it right before the
      reset of the temp generator) so the optimizer can know which registers are
      regvars

  Revision 1.44  2000/01/28 23:17:53  florian
    * virtual XXXX; support for objects, only if -dWITHDMT is defined

  Revision 1.43  2000/01/21 22:06:16  florian
    * fixed for the fix of bug 793
    * fpu variables modified by nested subroutines aren't regable anymore
    * $maxfpuregisters doesn't modify anymore the behavior of a procedure before

  Revision 1.42  2000/01/16 22:17:12  peter
    * renamed call_offset to para_offset

  Revision 1.41  2000/01/11 17:16:06  jonas
    * removed a lot of memory leaks when an error is encountered (caused by
      procinfo and pstringcontainers). There are still plenty left though :)

  Revision 1.40  2000/01/07 01:14:31  peter
    * updated copyright to 2000

  Revision 1.39  1999/12/22 01:01:52  peter
    - removed freelabel()
    * added undefined label detection in internal assembler, this prevents
      a lot of ld crashes and wrong .o files
    * .o files aren't written anymore if errors have occured
    * inlining of assembler labels is now correct

  Revision 1.38  1999/12/06 18:17:09  peter
    * newcg compiler compiles again

  Revision 1.37  1999/11/30 10:40:48  peter
    + ttype, tsymlist

  Revision 1.36  1999/11/22 00:23:09  pierre
   * also complain about unused functions in program

  Revision 1.35  1999/11/17 17:05:02  pierre
   * Notes/hints changes

  Revision 1.34  1999/11/10 00:24:02  pierre
   * more browser details

  Revision 1.33  1999/11/09 23:43:08  pierre
   * better browser info

  Revision 1.32  1999/11/09 23:06:45  peter
    * esi_offset -> selfpointer_offset to be newcg compatible
    * hcogegen -> cgbase fixes for newcg

  Revision 1.31  1999/11/06 14:34:23  peter
    * truncated log to 20 revs

  Revision 1.30  1999/10/26 12:30:44  peter
    * const parameter is now checked
    * better and generic check if a node can be used for assigning
    * export fixes
    * procvar equal works now (it never had worked at least from 0.99.8)
    * defcoll changed to linkedlist with pparaitem so it can easily be
      walked both directions

  Revision 1.29  1999/10/22 10:39:35  peter
    * split type reading from pdecl to ptype unit
    * parameter_dec routine is now used for procedure and procvars

  Revision 1.28  1999/10/13 10:37:36  peter
    * moved mangledname creation of normal proc so it also handles a wrong
      method proc

}