fpc/compiler/new/psub.pas

{
    $Id$
    Copyright (c) 1998 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,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 }

procedure compile_proc_body(const proc_names:Tstringcontainer;
                            make_global,parent_has_class:boolean);
procedure parse_proc_head(options : word);
procedure parse_proc_dec;
procedure parse_var_proc_directives(var sym : ptypesym);
procedure read_proc;


implementation

uses
  globtype,systems,tokens,
  strings,globals,verbose,comphook,files,
  scanner,aasm,tree,types,
  import,gendef,
  convtree,
  hcodegen,temp_gen,pass_1,pass_2,cgobj
{$ifdef GDB}
  ,gdb
{$endif GDB}
{$ifdef i386}
  ,i386base,tgeni386
  {$ifndef NoOpt}
  ,aopt386
  {$endif}
{$endif}
{$ifdef m68k}
  ,m68k,tgen68k,cga68k
{$endif}
  { parser specific stuff }
  ,pbase,pdecl,pexpr,pstatmnt
  ;

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


procedure formal_parameter_list;
{
  handle_procvar needs the same changes
}
var
  sc      : Pstringcontainer;
  s       : string;
  filepos : tfileposinfo;
  p       : Pdef;
  vs      : Pvarsym;
  l       : longint;
  hs1,hs2 : string;
  varspez : Tvarspez;

begin
  consume(LKLAMMER);
  inc(testcurobject);
  repeat
    case token of
     _VAR : begin
              consume(_VAR);
              varspez:=vs_var;
            end;
   _CONST : begin
              consume(_CONST);
              varspez:=vs_const;
            end;
    else
      varspez:=vs_value;
    end;

  { read identifiers }

    sc:=idlist;
  { read type declaration, force reading for value and const paras }

    if (token=COLON) or (varspez=vs_value) then
     begin
       consume(COLON);
     { check for an open array }
       if token=_ARRAY then
        begin
          consume(_ARRAY);
          consume(_OF);
        { define range and type of range }
          p:=new(Parraydef,init(0,-1,s32bitdef));
        { array of const ? }
          if (token=_CONST) and (m_objpas in aktmodeswitches) then
           begin
             consume(_CONST);
             srsym:=nil;
             if assigned(objpasunit) then
              getsymonlyin(objpasunit,'TVARREC');
             if not assigned(srsym) then
              InternalError(1234124);
             Parraydef(p)^.definition:=ptypesym(srsym)^.definition;
             Parraydef(p)^.IsArrayOfConst:=true;
             hs1:='array_of_const';
           end
          else
           begin
           { define field type }
             Parraydef(p)^.definition:=single_type(hs1);
             hs1:='array_of_'+hs1;
           end;
        end
       { open string ? }
       else if ((token=_STRING) or (idtoken=_SHORTSTRING)) and
               (varspez=vs_var) and
               (cs_openstring in aktmoduleswitches) and
               not(cs_ansistrings in aktlocalswitches) then
        begin
          consume(token);
          p:=openshortstringdef;
          hs1:='openstring';
        end
       { everything else }
       else
        p:=single_type(hs1);
     end
    else
     begin
{$ifdef NoNiceNames}
       hs1:='$$$';
{$else UseNiceNames}
       hs1:='var';
{$endif UseNiceNames}
       p:=new(Pformaldef,init);
     end;
    hs2:=aktprocsym^.definition^.mangledname;
    while not sc^.empty do
     begin
       s:=sc^.get_with_tokeninfo(filepos);
       aktprocsym^.definition^.concatdef(p,varspez);
{$ifdef NoNiceNames}
       hs2:=hs2+'$'+hs1;
{$else UseNiceNames}
       hs2:=hs2+tostr(length(hs1))+hs1;
{$endif UseNiceNames}
       vs:=new(Pvarsym,init(s,p));
       vs^.fileinfo:=filepos;
       vs^.varspez:=varspez;
     { we have to add this to avoid var param to be in registers !!!}
       if (varspez in [vs_var,vs_const]) and push_addr_param(p) then
         vs^.var_options := vs^.var_options or vo_regable;

       { search for duplicate ids in object members/methods    }
       { but only the current class, I don't know why ...      }
       { at least TP and Delphi do it in that way         (FK) }
       if assigned(procinfo._class) and (lexlevel=normal_function_level) and
          (procinfo._class^.publicsyms^.search(vs^.name)<>nil) then
      {   (search_class_member(procinfo._class,vs^.name)<>nil) then }
         Message1(sym_e_duplicate_id,vs^.name);

       { when it is a value para and it needs a local copy then rename
         the parameter and insert a copy in the localst }
       if (varspez=vs_value) and push_addr_param(p) then
         begin
           vs^.islocalcopy:=true;
           aktprocsym^.definition^.localst^.insert(vs);
           vs^.is_valid:=1;
           l:=vs^.address; { save local address }
           vs:=new(Pvarsym,init('val'+s,p));
           vs^.fileinfo:=filepos;
           vs^.varspez:=varspez;
           aktprocsym^.definition^.parast^.insert(vs);
         end
       else
         aktprocsym^.definition^.parast^.insert(vs);
     end;
    dispose(sc,done);
    aktprocsym^.definition^.setmangledname(hs2);
    if token=SEMICOLON then
      consume(SEMICOLON)
    else
      break;
  until false;
  dec(testcurobject);
  consume(RKLAMMER);
end;



procedure parse_proc_head(options : word);
var sp:stringid;
    pd:Pprocdef;
    paramoffset:longint;
    sym:Psym;
    hs:string;
    overloaded_level:word;
    realfilepos : tfileposinfo;
begin
  if (options and pooperator) <> 0 then
    begin
      sp:=overloaded_names[optoken];
      realname:=sp;
    end
  else
    begin
      sp:=pattern;
      realname:=orgpattern;
      realfilepos:=aktfilepos;
      consume(ID);
    end;

{ method ? }
  if (token=POINT) and not(parse_only) then
   begin
     consume(POINT);
     getsym(sp,true);
     sym:=srsym;
     { qualifier is class name ? }
     if (sym^.typ<>typesym) or
        (ptypesym(sym)^.definition^.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)^.definition);
          sp:=pattern;
          realname:=orgpattern;
          consume(ID);
          procinfo._class:=pobjectdef(ptypesym(sym)^.definition);
          aktprocsym:=pprocsym(procinfo._class^.publicsyms^.search(sp));
          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 and (poconstructor or podestructor))<>0) then
        Message(parser_e_constructors_always_objects);

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

     if lexlevel=normal_function_level then
{$ifdef UseNiceNames}
       hs:=procprefix+'_'+tostr(length(sp))+sp
{$else UseNiceNames}
       hs:=procprefix+'_'+sp
{$endif UseNiceNames}
     else
{$ifdef UseNiceNames}
       hs:=lowercase(procprefix)+'_'+tostr(length(sp))+sp;
{$else UseNiceNames}
       hs:=procprefix+'_$'+sp;
{$endif UseNiceNames}
     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) 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
                Message1(sym_e_duplicate_id,aktprocsym^.Name);
               {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;
  { problem with procedures inside methods }
{$ifndef UseNiceNames}
  if assigned(procinfo._class) then
    if (pos('_$$_',procprefix)=0) then
      hs:=procprefix+'_$$_'+procinfo._class^.name+'_'+sp
    else
      hs:=procprefix+'_$'+sp;
{$else UseNiceNames}
  if assigned(procinfo._class) then
    if (pos('_5Class_',procprefix)=0) then
      hs:=procprefix+'_5Class_'+procinfo._class^.name^+'_'+tostr(length(sp))+sp
    else
      hs:=procprefix+'_'+tostr(length(sp))+sp;
{$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
           Message1(sym_e_duplicate_id,aktprocsym^.name);
           { try to recover by creating a new aktprocsym }
           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 }
           aktprocsym:=new(pprocsym,init(sp));
         end;
      end;
   end
  else
   begin
     { create a new procsym and set the real filepos }
     aktprocsym:=new(pprocsym,init(sp));
     aktprocsym^.fileinfo:=realfilepos;
     { for operator we have only one definition for each overloaded
       operation }
     if ((options and pooperator) <> 0) 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;
     symtablestack^.insert(aktprocsym);
   end;

{ create a new procdef }
  pd:=new(pprocdef,init);
  if assigned(procinfo._class) then
    pd^._class := procinfo._class;

  { set the options from the caller (podestructor or poconstructor) }
  pd^.options:=pd^.options or 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);
    end;

  if assigned (Procinfo._Class) and not(procinfo._class^.isclass) and
     (((pd^.options and poconstructor)<>0) or ((pd^.options and podestructor)<>0)) 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.ESI_offset:=paramoffset;
      inc(paramoffset,target_os.size_of_pointer);
    end;

  procinfo.call_offset:=paramoffset;

  pd^.parast^.datasize:=0;

  pd^.nextoverloaded:=aktprocsym^.definition;
  aktprocsym^.definition:=pd;
  aktprocsym^.definition^.setmangledname(hs);

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

  if token=LKLAMMER then
    formal_parameter_list;
  if ((options and pooperator)<>0) {and (overloaded_operators[optoken]=nil) } 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(0);
                   if token<>COLON then
                    begin
                      if not(aktprocsym^.definition^.forwarddef) and
                         not(m_repeat_forward in aktmodeswitches) then
                       begin
                         consume(COLON);
                         consume_all_until(SEMICOLON);
                       end;
                    end
                   else
                    begin
                      consume(COLON);
                      aktprocsym^.definition^.retdef:=single_type(hs);
                      aktprocsym^.definition^.test_if_fpu_result;
                    end;
                 end;
    _PROCEDURE : begin
                   consume(_PROCEDURE);
                   parse_proc_head(0);
                   aktprocsym^.definition^.retdef:=voiddef;
                 end;
  _CONSTRUCTOR : begin
                   consume(_CONSTRUCTOR);
                   parse_proc_head(poconstructor);
                   if (procinfo._class^.options and oo_is_class)<>0 then
                    begin
                      { CLASS constructors return the created instance }
                      aktprocsym^.definition^.retdef:=procinfo._class;
                    end
                   else
                    begin
                      { OBJECT constructors return a boolean }
{$IfDef GDB}
                      { GDB doesn't like unnamed types !}
                      aktprocsym^.definition^.retdef:=globaldef('boolean');
{$Else GDB}
                      aktprocsym^.definition^.retdef:=new(porddef,init(bool8bit,0,1));
{$Endif GDB}
                    end;
                 end;
   _DESTRUCTOR : begin
                   consume(_DESTRUCTOR);
                   parse_proc_head(podestructor);
                   aktprocsym^.definition^.retdef:=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(pooperator);
                   if token<>ID then
                     consume(ID)
                   else
                     begin
                       opsym:=new(pvarsym,init(pattern,voiddef));
                       consume(ID);
                     end;
                   if token<>COLON then
                     begin
                       consume(COLON);
                       aktprocsym^.definition^.retdef:=generrordef;
                       consume_all_until(SEMICOLON);
                     end
                   else
                    begin
                      consume(COLON);
                      aktprocsym^.definition^.retdef:=
                       single_type(hs);
                      aktprocsym^.definition^.test_if_fpu_result;
                      if (optoken in [EQUAL,GT,LT,GTE,LTE]) and
                         ((aktprocsym^.definition^.retdef^.deftype<>
                         orddef) or (porddef(aktprocsym^.definition^.
                         retdef)^.typ<>bool8bit)) then
                        Message(parser_e_comparative_operator_return_boolean);
                       opsym^.definition:=aktprocsym^.definition^.retdef;
                     end;
                 end;
  end;
  if isclassmethod and
     assigned(aktprocsym) then
    aktprocsym^.definition^.options:=aktprocsym^.definition^.options or poclassmethod;
  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
  procnames.insert(realname);
  procinfo.exported:=true;
  if cs_link_deffile in aktglobalswitches then
    deffile.AddExport(aktprocsym^.definition^.mangledname);
  if assigned(procinfo._class) then
    Message(parser_e_methods_dont_be_export);
  if lexlevel<>normal_function_level then
    Message(parser_e_dont_nest_export);
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;
  aktprocsym^.properties:=aktprocsym^.properties or sp_forwarddef;
end;

procedure pd_stdcall(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_cdecl(const procnames:Tstringcontainer);
begin
  if aktprocsym^.definition^.deftype<>procvardef then
    aktprocsym^.definition^.setmangledname(target_os.Cprefix+realname);
end;


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


procedure pd_syscall(const procnames:Tstringcontainer);
begin
  aktprocsym^.definition^.options:=aktprocsym^.definition^.options or poclearstack;
  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
        Message(parser_w_empty_import_name);
      if not(current_module^.uses_imports) then
       begin
         current_module^.uses_imports:=true;
         importlib^.preparelib(current_module^.modulename^);
       end;
      importlib^.importprocedure(aktprocsym^.mangledname,import_dll,import_nr,import_name)
    end
  else
    begin
      if (idtoken=_NAME) then
       begin
         consume(_NAME);
         aktprocsym^.definition^.setmangledname(get_stringconst);
       end
      else
       begin
         { external shouldn't override the cdecl/system name }
         if (aktprocsym^.definition^.options and poclearstack)=0 then
           aktprocsym^.definition^.setmangledname(aktprocsym^.name);
       end;
    end;
end;

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

function parse_proc_direc(const name:string;const proc_names:Tstringcontainer;var pdflags:word):boolean;
{
  Parse the procedure directive, returns true if a correct directive is found
}
const
   namelength=15;
type
   pd_handler=procedure(const procnames:Tstringcontainer);
   proc_dir_rec=record
     name     : string[namelength]; {15 letters should be enough.}
     handler  : pd_handler;         {Handler.}
     flag     : longint;            {Procedure flag. May be zero}
     pd_flags : longint;             {Parse options}
     mut_excl : longint;             {List of mutually exclusive flags.}
   end;
const
  {Should contain the number of procedure directives we support.}
  num_proc_directives=21;
  {Should contain the largest power of 2 lower than
   num_proc_directives, the int value of the 2-log of it. Cannot be
   calculated using an constant expression, as far as I know.}
  num_proc_directives_2log=16;

  proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
   ((name:'ALIAS'     ;handler:{$ifdef FPC}@{$endif}pd_alias;
      flag:0            ;pd_flags:pd_implemen+pd_body;
      mut_excl:poinline+poexternal),
    (name:'ASMNAME' ;handler:{$ifdef FPC}@{$endif}pd_asmname;
      flag:pocdecl+poclearstack+poexternal;pd_flags:pd_interface+pd_implemen;
      mut_excl:pointernproc+poexternal),
    (name:'ASSEMBLER' ;handler:nil;
      flag:poassembler  ;pd_flags:pd_implemen+pd_body;
      mut_excl:pointernproc+poexternal),
    (name:'CDECL'     ;handler:{$ifdef FPC}@{$endif}pd_cdecl;
      flag:pocdecl+poclearstack;pd_flags:pd_interface+pd_implemen+pd_body+pd_procvar;
      mut_excl:poleftright+poinline+poassembler+pointernproc+poexternal),
    (name:'EXPORT'    ;handler:{$ifdef FPC}@{$endif}pd_export;
      flag:poexports    ;pd_flags:pd_body+pd_global+pd_interface+pd_implemen{??};
      mut_excl:poexternal+poinline+pointernproc+pointerrupt),
    (name:'EXTERNAL'  ;handler:{$ifdef FPC}@{$endif}pd_external;
      flag:poexternal   ;pd_flags:pd_implemen;
      mut_excl:poexports+poinline+pointernproc+pointerrupt+poassembler+popalmossyscall),
    (name:'FAR'       ;handler:{$ifdef FPC}@{$endif}pd_far;
      flag:0            ;pd_flags:pd_implemen+pd_body+pd_interface+pd_procvar;
      mut_excl:pointernproc),
    (name:'FORWARD'   ;handler:{$ifdef FPC}@{$endif}pd_forward;
      flag:0            ;pd_flags:pd_implemen;
      mut_excl:pointernproc+poexternal),
    (name:'INLINE'    ;handler:{$ifdef FPC}@{$endif}pd_inline;
      flag:poinline     ;pd_flags:pd_implemen+pd_body;
      mut_excl:poexports+poexternal+pointernproc+pointerrupt+poconstructor+podestructor),
    (name:'INTERNCONST';handler:{$ifdef FPC}@{$endif}pd_intern;
      flag:pointernconst;pd_flags:pd_implemen+pd_body;
      mut_excl:pointernproc+pooperator),
    (name:'INTERNPROC';handler:{$ifdef FPC}@{$endif}pd_intern;
      flag:pointernproc ;pd_flags:pd_implemen;
      mut_excl:poexports+poexternal+pointerrupt+poassembler+poclearstack+poleftright+poiocheck+
               poconstructor+podestructor+pooperator),
    (name:'INTERRUPT' ;handler:nil;
      flag:pointerrupt  ;pd_flags:pd_implemen+pd_body;
      mut_excl:pointernproc+poclearstack+poleftright+poinline+
        poconstructor+podestructor+pooperator+poexternal),
    (name:'IOCHECK'   ;handler:nil;
      flag:poiocheck    ;pd_flags:pd_implemen+pd_body;
      mut_excl:pointernproc+poexternal),
    (name:'NEAR'      ;handler:{$ifdef FPC}@{$endif}pd_near;
      flag:0            ;pd_flags:pd_implemen+pd_body+pd_procvar;
      mut_excl:pointernproc),
    (name:'PASCAL'    ;handler:nil;
      flag:poleftright  ;pd_flags:pd_implemen+pd_body+pd_procvar;
      mut_excl:pointernproc+poexternal),
    (name:'POPSTACK'  ;handler:nil;
      flag:poclearstack ;pd_flags:pd_interface+pd_implemen+pd_body+pd_procvar;
      mut_excl:poinline+pointernproc+poassembler+poexternal),
    (name:'PUBLIC'    ;handler:nil;
      flag:0            ;pd_flags:pd_implemen+pd_body+pd_global;
      mut_excl:pointernproc+poinline+poexternal),
    (name:'REGISTER'    ;handler:{$ifdef FPC}@{$endif}pd_register;
      flag:poregister   ;pd_flags:pd_interface+pd_implemen+pd_body+pd_procvar;
      mut_excl:poleftright+pocdecl+pointernproc+poexternal),
    (name:'STDCALL'    ;handler:{$ifdef FPC}@{$endif}pd_stdcall;
      flag:postdcall    ;pd_flags:pd_interface+pd_implemen+pd_body+pd_procvar;
      mut_excl:poleftright+pocdecl+pointernproc+poinline+poexternal),
    (name:'SYSCALL'    ;handler:{$ifdef FPC}@{$endif}pd_syscall;
      flag:popalmossyscall;pd_flags:pd_interface;
      mut_excl:poexports+poinline+pointernproc+pointerrupt+poassembler+poexternal),
    (name:'SYSTEM'     ;handler:{$ifdef FPC}@{$endif}pd_system;
      flag:poclearstack ;pd_flags:pd_implemen;
      mut_excl:poleftright+poinline+poassembler+pointernproc+poexternal));

var
  p,w : longint;
begin
  parse_proc_direc:=false;
{ Search the procedure directive in the array. We shoot with a bazooka
  on a bug, that is, we release a binary search }
  p:=1;
  if (length(name)<=namelength) then
   begin
     w:=num_proc_directives_2log;
     while w<>0 do
       begin
         if proc_direcdata[p+w].name<=name then
          inc(p,w);
         w:=w shr 1;
         while p+w>num_proc_directives do
          w:=w shr 1;
       end;
   end;
{ Check if the procedure directive is known }
  if name<>proc_direcdata[p].name then
   begin
      { parsing a procvar type the name can be any
        next variable !! }
      if (pdflags and pd_procvar)=0 then
        Message1(parser_w_unknown_proc_directive_ignored,name);
      exit;
   end;

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

{ Conflicts between directives ? }
  if (aktprocsym^.definition^.options and proc_direcdata[p].mut_excl)<>0 then
   begin
     Message1(parser_e_proc_dir_conflict,name);
     exit;
   end;

{ 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^.options:=aktprocsym^.definition^.options or proc_direcdata[p].flag;

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

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

function check_identical: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
}
const
{List of procedure options that affect the procedure type.}
  po_type_params=poconstructor+podestructor+pooperator;

  po_call_params=pocdecl+poclearstack+poleftright+poregister;

var
  hd,pd : Pprocdef;
  storeparast : psymtable;
  ad,fd : psym;
begin
  check_identical:=false;
  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) or
              equal_paras(aktprocsym^.definition^.para1,pd^.nextoverloaded^.para1,false) 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^.options and po_type_params)<>(aktprocsym^.definition^.options and po_type_params)) or
                      (not(is_equal(hd^.retdef,aktprocsym^.definition^.retdef)) and
                      (m_repeat_forward in aktmodeswitches)) then
                     begin
                       Message1(parser_e_header_dont_match_forward,aktprocsym^.demangledName);
                       exit;
                     end;
                 { Check calling convention }
                   if ((hd^.options and po_call_params)<>(aktprocsym^.definition^.options and po_call_params)) then
                    begin
                    { only trigger a error, becuase it doesn't hurt }
                      Message(parser_e_call_convention_dont_match_forward);
                    end;
                 { manglednames are equal? }
                   if (m_repeat_forward in aktmodeswitches) or
                      aktprocsym^.definition^.haspara then
                    if (hd^.mangledname<>aktprocsym^.definition^.mangledname) then
                     begin
                       if (aktprocsym^.definition^.options and poexternal)=0 then
                         Message(parser_n_interface_name_diff_implementation_name);
                     { reset the mangledname of the interface part to be sure }
                     { this is wrong because the mangled name might have been used already !! }
                     { hd^.setmangledname(aktprocsym^.definition^.mangledname);}
                     { so we need to keep the name of interface !! }
                       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;

                     end;
                 { also the call_offset }
                   hd^.parast^.address_fixup:=aktprocsym^.definition^.parast^.address_fixup;

                 { 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^.options:=hd^.options or aktprocsym^.definition^.options;
                   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;
                   aktprocsym^.definition:=hd;
                   check_identical:=true;
                 end
               else
               { abstract methods aren't forward defined, but this }
               { needs another error message                       }
                 if (pd^.nextoverloaded^.options and poabstractmethod)=0 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 not parse_only then
    begin
      if ret_in_param(aktprocsym^.definition^.retdef) 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^.getsize);
          { 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,oldquickexitlabel:Pasmlabel;
   _class,hp:Pobjectdef;
   { switches can change inside the procedure }
   entryswitches, exitswitches : tlocalswitches;
   { code for the subroutine as tree }
   code : pnode;
   { 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);
   { save old labels }
   oldexitlabel:=aktexitlabel;
   oldexit2label:=aktexit2label;
   oldquickexitlabel:=quickexitlabel;
   { get new labels }
   getlabel(aktexitlabel);
   getlabel(aktexit2label);
   { exit for fail in constructors }
   if (aktprocsym^.definition^.options and poconstructor)<>0 then
     getlabel(quickexitlabel);
   { reset break and continue labels }
   in_except_block:=false;
   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^.publicsyms^.next:=symtablestack;
         symtablestack:=_class^.publicsyms;
       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;
   { no registers are used }
   usedinproc:=0;

   { save entry info }
   entrypos:=aktfilepos;
   entryswitches:=aktlocalswitches;

   { parse the code ... }
   if (aktprocsym^.definition^.options and poassembler)<> 0 then
     code:=convtree2node(assembler_block)
   else
     code:=convtree2node(block(current_module^.islibrary));


   { 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 }
   setfirsttemp(procinfo.firsttemp);

   { ... and generate assembler }
   { but set the right switches for entry !! }
   aktlocalswitches:=entryswitches;
   if assigned(code) then
     generatecode(code);
   { 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;
        aktprocsym^.definition^.usedregisters:=usedinproc;
     end;

   stackframe:=gettempsize;
   { only now we can remove the temps }
   resettempgen;

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

   { now generate exit code with the correct position and switches }
   aktfilepos:=exitpos;
   aktlocalswitches:=exitswitches;
   if assigned(code) then
     begin
       cg^.g_exitcode(procinfo.aktexitcode,parasize,nostackframe,false);
       procinfo.aktproccode^.insertlist(procinfo.aktentrycode);
       procinfo.aktproccode^.concatlist(procinfo.aktexitcode);
{$ifdef i386}
 {$ifndef NoOpt}
       if (cs_optimize in aktglobalswitches) and
       { no asm block allowed }
         ((procinfo.flags and pi_uses_asm)=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);
         end;
       { now we can insert a cut }
       if (cs_smartlink in aktmoduleswitches) then
         codesegment^.concat(new(pai_cut,init));

       { add the procedure to the codesegment }
       codesegment^.concatlist(procinfo.aktproccode);
     end;

   { ... 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 (status.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 (aktprocsym^.definition^.options and (pounitinit or pounitfinalize))=0 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
      ((aktprocsym^.definition^.options and poinline)=0) then
     begin
       if lexlevel>=normal_function_level then
         dispose(aktprocsym^.definition^.localst,done);
       aktprocsym^.definition^.localst:=nil;
     end;

    { remove code tree, if not inline procedure }
    if assigned(code) and ((aktprocsym^.definition^.options and poinline)=0) then
      dispose(code,done);

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

   { restore filepos, the switches are already set }
   aktfilepos:=savepos;
   { free labels }
   freelabel(aktexitlabel);
   freelabel(aktexit2label);
   if (aktprocsym^.definition^.options and poconstructor)<>0 then
    freelabel(quickexitlabel);
   { restore labels }
   aktexitlabel:=oldexitlabel;
   aktexit2label:=oldexit2label;
   quickexitlabel:=oldquickexitlabel;
   { 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
  name : string;
  res  : boolean;
begin
  while token in [ID,LECKKLAMMER] do
   begin
     if token=LECKKLAMMER then
      begin
        consume(LECKKLAMMER);
        repeat
          name:=pattern;
          { consume(ID);
          now done in the function }
          parse_proc_direc(name,Anames^,pdflags);
          if token=COMMA then
           consume(COMMA)
          else
           break;
        until false;
        consume(RECKKLAMMER);
        { we always expect at least '[];' }
        res:=true;
      end
     else
      begin
        name:=pattern;
        res:=parse_proc_direc(name,Anames^,pdflags);
      end;
   { A procedure directive is always followed by a semicolon }
     if res then
      consume(SEMICOLON)
     else
      break;
   end;
end;

procedure parse_var_proc_directives(var sym : ptypesym);
var
  anames : pstringcontainer;
  pdflags : word;
  oldsym : pprocsym;
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));
  aktprocsym^.definition:=pprocdef(sym^.definition);
  { anmes 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 read_proc;
{
  Parses the procedure directives, then parses the procedure body, then
  generates the code for it
}
var
  oldprefix        : string;
  oldprocsym       : Pprocsym;
  oldprocinfo      : tprocinfo;
  oldconstsymtable : Psymtable;
  names            : Pstringcontainer;
  pdflags          : word;
begin
{ save old state }
   oldprocsym:=aktprocsym;
   oldprefix:=procprefix;
   oldconstsymtable:=constsymtable;
   oldprocinfo:=procinfo;
{ create a new procedure }
   new(names,init);
   codegen_newprocedure;
   with procinfo do
    begin
      parent:=@oldprocinfo;
    { clear flags }
      flags:=0;
    { standard frame pointer }
      framepointer:=frame_pointer;
      funcret_is_valid:=false;
    { is this a nested function of a method ? }
      _class:=oldprocinfo._class;
    end;

   parse_proc_dec;

{ set the default function options }
   if parse_only then
    begin
      aktprocsym^.properties:=aktprocsym^.properties or sp_forwarddef;
      aktprocsym^.definition^.forwarddef:=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_smartlink 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);

{ search for forward declarations }
   if (not check_identical) 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);
     { check the global flag }
       if (procinfo.flags and pi_is_global)<>0 then
         Message(parser_e_overloaded_must_be_all_global);
     end;

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

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

{ 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^.options and poconstructor)<>0 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^.options and poconstructor)<>0 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 }
   dispose(names,done);
   codegen_doneprocedure;
{ Restore old state }
   constsymtable:=oldconstsymtable;
   aktprocsym:=oldprocsym;
   procprefix:=oldprefix;
   procinfo:=oldprocinfo;
   opsym:=nil;
end;

end.

{
  $Log$
  Revision 1.3  1999-08-01 18:22:38  florian
   * made it again compilable

  Revision 1.2  1999/01/13 22:52:39  florian
    + YES, finally the new code generator is compilable, but it doesn't run yet :(

  Revision 1.1  1998/12/26 15:20:31  florian
    + more changes for the new version

}