AmigActive 2/AACD 2.iso/AACD/Programming/fpc/compiler/pstatmnt.pas

Pascal/Delphi Source File | 1998-09-24 | 39.6 KB | 1,183 lines

{
    $Id: pstatmnt.pas,v 1.3.2.1 1998/08/05 14:07:34 pierre Exp $
    Copyright (c) 1998 by Florian Klaempfl

    Does the parsing of the statements

    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 pstatmnt;

  interface

    uses tree;

    var
       { true, if we are in a except block }
       in_except_block : boolean;

    { reads a block }
    function block(islibrary : boolean) : ptree;

    { reads an assembler block }
    function assembler_block : ptree;

  implementation

    uses
       cobjects,scanner,globals,symtable,aasm,pass_1,
       types,hcodegen,files,verbose
       { processor specific stuff }
{$ifdef i386}
       ,i386
       ,rai386
       ,ratti386
       ,radi386
       ,tgeni386
{$endif}
{$ifdef m68k}
       ,m68k
       ,tgen68k
       ,ag68kmit
       ,ra68k
       ,ag68kgas
       ,ag68kmot
{$endif}
       { parser specific stuff, be careful consume is also defined to }
       { read assembler tokens                                        }
       ,pbase,pexpr,pdecl;


    function statement : ptree;forward;

    function if_statement : ptree;

      var
         ex,if_a,else_a : ptree;

      begin
         consume(_IF);
         ex:=expr;
         consume(_THEN);
         if token<>_ELSE then
           if_a:=statement
         else
       if_a:=nil;

         if token=_ELSE then
           begin
              consume(_ELSE);
              else_a:=statement;
           end
         else
           else_a:=nil;
         if_statement:=genloopnode(ifn,ex,if_a,else_a,false);
      end;

    { creates a block (list) of statements, til the next END token }
    function statements_til_end : ptree;

      var
         first,last : ptree;

      begin
         first:=nil;
         while token<>_END do
           begin
              if first=nil then
                begin
                   last:=gennode(anwein,nil,statement);
                   first:=last;
                end
              else
                begin
                   last^.left:=gennode(anwein,nil,statement);
                   last:=last^.left;
                end;
              if token<>SEMICOLON then
                break
              else
                consume(SEMICOLON);
              while token=SEMICOLON do
                consume(SEMICOLON);

           end;
         consume(_END);
         statements_til_end:=gensinglenode(blockn,first);
      end;

    function case_statement : ptree;

      var
         { contains the label number of currently parsed case block }
         aktcaselabel : plabel;
         wurzel : pcaserecord;

         { the typ of the case expression }
         casedef : pdef;

      procedure newcaselabel(l,h : longint);

        var
           hcaselabel : pcaserecord;

        procedure insertlabel(var p : pcaserecord);

          begin
             if p=nil then p:=hcaselabel
             else
                if (p^._low>hcaselabel^._low) and
                   (p^._low>hcaselabel^._high) then
                  insertlabel(p^.less)
                else if (p^._high<hcaselabel^._low) and
                   (p^._high<hcaselabel^._high) then
                  insertlabel(p^.greater)
                else Message(parser_e_double_caselabel);
          end;

        begin
           new(hcaselabel);
           hcaselabel^.less:=nil;
           hcaselabel^.greater:=nil;
           hcaselabel^.statement:=aktcaselabel;
           getlabel(hcaselabel^._at);
           hcaselabel^._low:=l;
           hcaselabel^._high:=h;
           insertlabel(wurzel);
        end;

      var
         code,caseexpr,p,instruc,elseblock : ptree;
         hl1,hl2 : longint;
         ranges : boolean;

      begin
         consume(_CASE);
         caseexpr:=expr;
         { determines result type }
         cleartempgen;
         do_firstpass(caseexpr);
         casedef:=caseexpr^.resulttype;

         if not(is_ordinal(casedef)) then
           Message(parser_e_ordinal_expected);

         consume(_OF);
         wurzel:=nil;
         ranges:=false;
         instruc:=nil;
         repeat
           getlabel(aktcaselabel);
           {aktcaselabel^.is_used:=true; }

           { an instruction has may be more case labels }
           repeat
             p:=expr;
             cleartempgen;
             do_firstpass(p);

             if (p^.treetype=rangen) then
               begin
                  { type checking for case statements }
                  if not is_subequal(casedef, p^.left^.resulttype) then
                    Message(parser_e_case_mismatch);
                  { type checking for case statements }
                  if not is_subequal(casedef, p^.right^.resulttype) then
                    Message(parser_e_case_mismatch);
                  hl1:=get_ordinal_value(p^.left);
                  hl2:=get_ordinal_value(p^.right);
                  testrange(casedef,hl1);
                  testrange(casedef,hl2);
                  newcaselabel(hl1,hl2);
                  ranges:=true;
               end
             else
               begin
                  { type checking for case statements }
                  if not is_subequal(casedef, p^.resulttype) then
                    Message(parser_e_case_mismatch);
                    hl1:=get_ordinal_value(p);
                    testrange(casedef,hl1);
                    newcaselabel(hl1,hl1);
               end;
             disposetree(p);
             if token=COMMA then consume(COMMA)
               else break;
           until false;
           consume(COLON);

           { handles instruction block }
           p:=gensinglenode(labeln,statement);
           p^.labelnr:=aktcaselabel;

           { concats instruction }
           instruc:=gennode(anwein,instruc,p);

           if not((token=_ELSE) or (token=_OTHERWISE) or (token=_END)) then
             consume(SEMICOLON);
         until (token=_ELSE) or (token=_OTHERWISE) or (token=_END);

         if (token=_ELSE) or (token=_OTHERWISE) then
           begin
              if token=_ELSE then consume(_ELSE)
                else consume(_OTHERWISE);
              elseblock:=statements_til_end;
           end
         else
           begin
              elseblock:=nil;
              consume(_END);
           end;

         code:=gencasenode(caseexpr,instruc,wurzel);

         code^.elseblock:=elseblock;

         case_statement:=code;
      end;

    function repeat_statement : ptree;

      var
         first,last,p_e : ptree;

      begin
         consume(_REPEAT);
         first:=nil;
         while token<>_UNTIL do
           begin
              if first=nil then
                begin
                   last:=gennode(anwein,nil,statement);
                   first:=last;
                end
              else
                begin
                   last^.left:=gennode(anwein,nil,statement);
                   last:=last^.left;
                end;
              if token<>SEMICOLON then
                break;
              consume(SEMICOLON);
              while token=SEMICOLON do
                consume(SEMICOLON);
           end;
         consume(_UNTIL);
         first:=gensinglenode(blockn,first);
         p_e:=expr;
         repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
      end;

    function while_statement : ptree;

      var
         p_e,p_a : ptree;

      begin
         consume(_WHILE);
     p_e:=expr;
         consume(_DO);
         p_a:=statement;
         while_statement:=genloopnode(whilen,p_e,p_a,nil,false);
      end;

    function for_statement : ptree;

      var
         p_e,tovalue,p_a : ptree;
         backward : boolean;

      begin
         { parse loop header }
         consume(_FOR);
         p_e:=expr;
         if token=_DOWNTO then
           begin
              consume(_DOWNTO);
              backward:=true;
           end
         else
           begin
              consume(_TO);
              backward:=false;
           end;
         tovalue:=expr;
         consume(_DO);

         { ... now the instruction }
                 p_a:=statement;
                 for_statement:=genloopnode(forn,p_e,tovalue,p_a,backward);
          end;

    function _with_statement : ptree;

      var
         right,hp,p : ptree;
         i,levelcount : longint;
         withsymtable,symtab : psymtable;
         obj : pobjectdef;

      begin
         Must_be_valid:=false;
         p:=expr;
         do_firstpass(p);
         right:=nil;
         case p^.resulttype^.deftype of
            objectdef : begin
                          obj:=pobjectdef(p^.resulttype);
                          levelcount:=0;
                          while assigned(obj) do
                            begin
                               symtab:=obj^.publicsyms;
                               withsymtable:=new(psymtable,init(symtable.withsymtable));
                               withsymtable^.wurzel:=symtab^.wurzel;
                               withsymtable^.next:=symtablestack;
                               symtablestack:=withsymtable;
                               obj:=obj^.childof;
                               inc(levelcount);
                            end;
                       end;
            recorddef : begin
                           symtab:=precdef(p^.resulttype)^.symtable;
                           levelcount:=1;
                           withsymtable:=new(psymtable,init(symtable.withsymtable));
                           withsymtable^.wurzel:=symtab^.wurzel;
                           withsymtable^.next:=symtablestack;
                           symtablestack:=withsymtable;
                        end;
            else
              begin
                    Message(parser_e_false_with_expr);
                    { try to recover from error }
                    if token=COMMA then
                      begin
                         consume(COMMA);
{$ifdef tp}
                                                 hp:=_with_statement;
{$else}
                                                 hp:=_with_statement();
{$endif}
                                          end
                                        else
                                          begin
                                                 consume(_DO);
                                                 { ignore all }
                                                 if token<>SEMICOLON then
                                                   statement;
                      end;
                    _with_statement:=nil;
                    exit;
                 end;
         end;
         if token=COMMA then
           begin
              consume(COMMA);
{$ifdef tp}
                          right:=_with_statement;
{$else}
              right:=_with_statement();
{$endif}
           end
         else
           begin
              consume(_DO);
              if token<>SEMICOLON then
                right:=statement
              else
                right:=nil;
           end;
         for i:=1 to levelcount do
           symtablestack:=symtablestack^.next;

         _with_statement:=genwithnode(withsymtable,p,right,levelcount);
      end;

    function with_statement : ptree;

      begin
         consume(_WITH);
         with_statement:=_with_statement;
      end;

    function raise_statement : ptree;

      var
         p1,p2 : ptree;

      begin
         p1:=nil;
         p2:=nil;
         consume(_RAISE);
         if token<>SEMICOLON then
           begin
              p1:=expr;
              if (token=ID) and (pattern='AT') then
                begin
                   consume(ID);
                   p2:=expr;
                end;
           end
         else
           begin
              if not(in_except_block) then
               Message(parser_e_no_reraise_possible);
           end;
         raise_statement:=gennode(raisen,p1,p2);
      end;

    function try_statement : ptree;

      var
         p_try_block,p_finally_block,first,last,
         p_default,e1,e2,p_specific : ptree;

         old_in_except_block : boolean;

      begin
         p_default:=nil;
         p_specific:=nil;

         { read statements to try }
         consume(_TRY);
         first:=nil;
         while (token<>_FINALLY) and (token<>_EXCEPT) do
                   begin
              if first=nil then
                begin
                                   last:=gennode(anwein,nil,statement);
                   first:=last;
                end
              else
                begin
                                   last^.left:=gennode(anwein,nil,statement);
                   last:=last^.left;
                end;
                          if token<>SEMICOLON then
                                break;
                          consume(SEMICOLON);
                          emptystats;
                   end;
         p_try_block:=gensinglenode(blockn,first);

         if token=_FINALLY then
           begin
              consume(_FINALLY);
              p_finally_block:=statements_til_end;
              try_statement:=gennode(tryfinallyn,p_try_block,p_finally_block);
           end
         else
           begin
              consume(_EXCEPT);
              old_in_except_block:=in_except_block;
              in_except_block:=true;

              if token=_ON then
                { catch specific exceptions }
                begin
                   repeat
                     consume(_ON);
             e1:=expr;
                     if token=COLON then
                       begin
                          consume(COLON);
              e2:=expr;
                          { !!!!! }
                       end
                     else
                       begin
                          { !!!!! }
                       end;
                     consume(_DO);
                                         statement;
                                         if token<>SEMICOLON then
                                           break;
                                         emptystats;
                                   until false;
                   if token=_ELSE then
                     { catch the other exceptions }
                     begin
                        consume(_ELSE);
                        p_default:=statements_til_end;
                     end;
                end
              else
                { catch all exceptions }
                begin
                   p_default:=statements_til_end;
                end;
              in_except_block:=old_in_except_block;
              try_statement:=genloopnode(tryexceptn,p_try_block,p_specific,p_default,false);
           end;
      end;

    function exit_statement : ptree;

      var
         p : ptree;

      begin
         consume(_EXIT);
         if token=LKLAMMER then
           begin
              consume(LKLAMMER);
          p:=expr;
              consume(RKLAMMER);
              if procinfo.retdef=pdef(voiddef) then
                Message(parser_e_void_function);
           end
         else
           p:=nil;
         exit_statement:=gensinglenode(exitn,p);
      end;


{$ifdef i386}
    function _asm_statement : ptree;

      begin
         case aktasmmode of
            I386_ATT : _asm_statement:=ratti386.assemble;
            I386_INTEL : _asm_statement:=rai386.assemble;
            I386_DIRECT : _asm_statement:=radi386.assemble;
            else internalerror(30004);
         end;

         { Erst am Ende _ASM konsumieren, da der Scanner sonst die }
         { erste Assemblerstatement zu lesen versucht! }
         consume(_ASM);

         { (END is read) }
         if token=LECKKLAMMER then
           begin
              { it's possible to specify the modified registers }
              consume(LECKKLAMMER);
              if token<>RECKKLAMMER then
                repeat
                  pattern:=upper(pattern);
                  if pattern='EAX' then
                    usedinproc:=usedinproc or ($80 shr byte(R_EAX))
                  else if pattern='EBX' then
                    usedinproc:=usedinproc or ($80 shr byte(R_EBX))
                  else if pattern='ECX' then
                    usedinproc:=usedinproc or ($80 shr byte(R_ECX))
                  else if pattern='EDX' then
                    usedinproc:=usedinproc or ($80 shr byte(R_EDX))
                  else if pattern='ESI' then
                    usedinproc:=usedinproc or ($80 shr byte(R_ESI))
                  else if pattern='EDI' then
                    usedinproc:=usedinproc or ($80 shr byte(R_EDI))
                  else consume(RECKKLAMMER);
                  consume(CSTRING);
                  if token=COMMA then consume(COMMA)
                    else break;
                until false;
              consume(RECKKLAMMER);
           end
         else usedinproc:=$ff;
      end;
{$endif}

{$ifdef m68k}
    function _asm_statement : ptree;
    begin
         _asm_statement:= ra68k.assemble;
         { Erst am Ende _ASM konsumieren, da der Scanner sonst die }
         { erste Assemblerstatement zu lesen versucht! }
         consume(_ASM);

         { (END is read) }
         if token=LECKKLAMMER then
           begin
              { it's possible to specify the modified registers }
              { we only check the registers which are not reserved }
              { and which can be used. This is done for future     }
              { optimizations.                                     }
              consume(LECKKLAMMER);
              if token<>RECKKLAMMER then
                repeat
                  pattern:=upper(pattern);
                  if pattern='D0' then
                    usedinproc:=usedinproc or ($800 shr word(R_D0))
                  else if pattern='D1' then
                    usedinproc:=usedinproc or ($800 shr word(R_D1))
                  else if pattern='D6' then
                    usedinproc:=usedinproc or ($800 shr word(R_D6))
                  else if pattern='A0' then
                    usedinproc:=usedinproc or ($800 shr word(R_A0))
                  else if pattern='A1' then
                    usedinproc:=usedinproc or ($800 shr word(R_A1))
                  else consume(RECKKLAMMER);
                  consume(CSTRING);
                  if token=COMMA then consume(COMMA)
                    else break;
                until false;
              consume(RECKKLAMMER);
           end
         else usedinproc:=$ffff;
    end;
{$endif}


        function new_dispose_statement : ptree;

          var
                 p,p2 : ptree;
                 ht : ttoken;
         again : boolean; { dummy for do_proc_call }
                 destrukname : stringid;
                 sym : psym;
                 classh : pobjectdef;
                 pd,pd2 : pdef;
                 store_valid : boolean;
                 tt : ttreetyp;

          begin
                 ht:=token;
                 if token=_NEW then consume(_NEW)
                   else consume(_DISPOSE);
                 if ht=_NEW then
                   tt:=hnewn
                 else
                   tt:=hdisposen;
                 consume(LKLAMMER);
                 p:=expr;

                 { calc return type }
                 cleartempgen;
                 Store_valid := Must_be_valid;
                 Must_be_valid := False;
                 do_firstpass(p);
                 Must_be_valid := Store_valid;

         {var o:Pobject;

                  begin
                      new(o,init);        (*Also a valid new statement*)
                  end;}

                 if token=COMMA then
                   begin
                          { extended syntax of new and dispose }
                          { function styled new is handled in factor }
                          consume(COMMA);
                          { destructors have no parameters }
                          destrukname:=pattern;
                          consume(ID);

                          pd:=p^.resulttype;
                          pd2:=pd;
                          if (p^.resulttype = nil) or (pd^.deftype<>pointerdef) then
                            begin
                               Message(parser_e_pointer_type_expected);
                               p:=factor(false);
                               consume(RKLAMMER);
                               new_dispose_statement:=genzeronode(errorn);
                               exit;
                            end;
                          { first parameter must be an object or class }
                          if ppointerdef(pd)^.definition^.deftype<>objectdef then
                            begin
                               Message(parser_e_pointer_to_class_expected);
                               new_dispose_statement:=factor(false);
                               consume_all_until(RKLAMMER);
                               consume(RKLAMMER);
                               exit;
                            end;
                          { check, if the first parameter is a pointer to a _class_ }
                          classh:=pobjectdef(ppointerdef(pd)^.definition);
                          if (classh^.options and oois_class)<>0 then
                                begin
                                   Message(parser_e_no_new_or_dispose_for_classes);
                                   new_dispose_statement:=factor(false);
                                   { while token<>RKLAMMER do
                                         consume(token); }
                                   consume_all_until(RKLAMMER);
                                   consume(RKLAMMER);
                                   exit;
                                end;
                          { search cons-/destructor, also in parent classes }
                          sym:=nil;
                          while assigned(classh) do
                                begin
                                   sym:=classh^.publicsyms^.search(pattern);
                                   srsymtable:=classh^.publicsyms;
                                   if assigned(sym) then
                                         break;
                                   classh:=classh^.childof;
                                end;
                          { the second parameter of new/dispose must be a call }
                          { to a cons-/destructor                                }
                          if (sym^.typ<>procsym) then
                                begin
                                   Message(parser_e_expr_have_to_be_destructor_call);
                                   new_dispose_statement:=genzeronode(errorn);
                                end
                          else
                                begin
                                  p2:=gensinglenode(tt,p);
                                  if ht=_NEW then
                                        begin
                                           { Constructors can take parameters.}
                                           p2^.resulttype:=ppointerdef(pd)^.definition;
                                           do_member_read(sym,p2,pd,again);
                                        end
                                  else
                                    { destructors can't.}
                                    p2:=genmethodcallnode(pprocsym(sym),srsymtable,p2);

                                  { we need the real called method }
                                  cleartempgen;
                                  do_firstpass(p2);

                                  if (ht=_NEW) and ((p2^.procdefinition^.options and poconstructor)=0) then
                                         Message(parser_e_expr_have_to_be_constructor_call);
                                  if (ht=_DISPOSE) and ((p2^.procdefinition^.options and podestructor)=0) then
                                         Message(parser_e_expr_have_to_be_destructor_call);

                                  if ht=_NEW then
                                        begin
                                                p2:=gennode(assignn,getcopy(p),gensinglenode(newn,p2));
                                                p2^.right^.resulttype:=pd2;
                                        end;
                                  new_dispose_statement:=p2;
                                end;
                   end
                 else
                   begin
                      if (p^.resulttype=nil) or (p^.resulttype^.deftype<>pointerdef) then
                        Begin
                           Message(parser_e_pointer_type_expected);
                           new_dispose_statement:=genzeronode(errorn);
                        end
                      else
                        begin
                           if (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) then
                            Message(parser_w_use_extended_syntax_for_objects);

                            case ht of
                               _NEW : new_dispose_statement:=gensinglenode(simplenewn,p);
                               _DISPOSE : new_dispose_statement:=gensinglenode(simpledisposen,p);
                            end;
                        end;
                   end;
                 consume(RKLAMMER);
          end;

    function statement_block : ptree;

      var
         first,last : ptree;

      begin
         first:=nil;
         consume(_BEGIN);
         while token<>_END do
           begin
              if first=nil then
                begin
                   last:=gennode(anwein,nil,statement);
                   first:=last;
                end
              else
                begin
                   last^.left:=gennode(anwein,nil,statement);
                   last:=last^.left;
                end;
              if token=_END then
                break
              else
                begin
                   { if no semicolon, then error and go on }
                   if token<>SEMICOLON then
                     begin
                        consume(SEMICOLON);
                        { while token<>SEMICOLON do
                          consume(token); }
                        consume_all_until(SEMICOLON);
                     end;
                   consume(SEMICOLON);
                end;
              emptystats;
           end;
         consume(_END);
         first:=gensinglenode(blockn,first);
         statement_block:=first;
      end;

    function statement : ptree;

      var
         p : ptree;
         code : ptree;
         labelnr : plabel;

      label
         ready;

      begin
         case token of
            _GOTO : begin
                       if not(cs_support_goto in aktswitches)then
                        Message(sym_e_goto_and_label_not_supported);
                       consume(_GOTO);
                       if (token<>INTCONST) and (token<>ID) then
                         begin
                            Message(sym_e_label_not_found);
                            code:=genzeronode(errorn);
                         end
                       else
                         begin
                            getsym(pattern,true);
                            consume(token);
                            if srsym^.typ<>labelsym then
                              begin
                                 Message(sym_e_id_is_no_label_id);
                                 code:=genzeronode(errorn);
                              end
                            else
                              code:=genlabelnode(goton,
                                plabelsym(srsym)^.number);
                         end;
                    end;
            _BEGIN : code:=statement_block;
            _IF    : code:=if_statement;
            _CASE  : code:=case_statement;
            _REPEAT : code:=repeat_statement;
            _WHILE : code:=while_statement;
            _FOR : code:=for_statement;
            _NEW,_DISPOSE : code:=new_dispose_statement;

            _WITH : code:=with_statement;
            _TRY : code:=try_statement;
            _RAISE : code:=raise_statement;
            { semicolons,else until and end are ignored }
            SEMICOLON,
            _ELSE,
            _UNTIL,
            _END : code:=genzeronode(niln);
            _CONTINUE : begin
                           consume(_CONTINUE);
                           code:=genzeronode(continuen);
                        end;
            _FAIL : begin
                       { internalerror(100); }
                       if (aktprocsym^.definition^.options and poconstructor)=0 then
                        Message(parser_e_fail_only_in_constructor);
                       consume(_FAIL);
                       code:=genzeronode(failn);
                    end;
            _BREAK:
              begin
                 consume(_BREAK);
                 code:=genzeronode(breakn);
              end;
            _EXIT : code:=exit_statement;
            _ASM : code:=_asm_statement;
         else
           begin
              if (token=INTCONST) or
                ((token=ID) and
                not((cs_delphi2_compatible in aktswitches) and
                (pattern='RESULT'))) then
                begin
                   getsym(pattern,false);
                   if assigned(srsym) and (srsym^.typ=labelsym) then
                     begin
                        consume(token);
                        consume(COLON);
                        if plabelsym(srsym)^.defined then
                          Message(sym_e_label_already_defined);
                        plabelsym(srsym)^.defined:=true;

                        { statement modifies srsym }
                        labelnr:=plabelsym(srsym)^.number;

                        { the pointer to the following instruction }
                        { isn't a very clean way                   }
{$ifdef tp}
                        code:=gensinglenode(labeln,statement);
{$else}
                        code:=gensinglenode(labeln,statement());
{$endif}
                        code^.labelnr:=labelnr;
                        { sorry, but there is a jump the easiest way }
                        goto ready;
                     end;
                end;
              p:=expr;
              if (p^.treetype<>calln) and
                (p^.treetype<>assignn) and
                (p^.treetype<>inlinen) then
                Message(cg_e_illegal_expression);
              code:=p;
           end;
         end;
         ready:
         statement:=code;
      end;

    function block(islibrary : boolean) : ptree;

{$ifdef TEST_FUNCRET }
      var
         funcretsym : pfuncretsym;
{$endif TEST_FUNCRET }

      begin
{$ifdef TEST_FUNCRET }
         if procinfo.retdef<>pdef(voiddef) then
           begin
              { if the current is a function aktprocsym is non nil }
              { and there is a local symtable set }
              funcretsym:=new(pfuncretsym,init(aktprocsym^.name),@procinfo);
              { insert in local symtable }
              symtablestack^.insert(funcretsym);
           end;
{$endif TEST_FUNCRET }
         read_declarations(islibrary);

         { temporary space is set, while the BEGIN of the procedure }
         if (symtablestack^.symtabletype=localsymtable) then
           procinfo.firsttemp := -symtablestack^.datasize
         else procinfo.firsttemp := 0;

         { space for the return value }
         { !!!!!   this means that we can not set the return value
         in a subfunction !!!!! }
         { because we don't know yet where the address is }
         if procinfo.retdef<>pdef(voiddef) then
           begin
              if ret_in_acc(procinfo.retdef) or (procinfo.retdef^.deftype=floatdef) then
              { if (procinfo.retdef^.deftype=orddef) or
                 (procinfo.retdef^.deftype=pointerdef) or
                 (procinfo.retdef^.deftype=enumdef) or
                 (procinfo.retdef^.deftype=procvardef) or
                 (procinfo.retdef^.deftype=floatdef) or
                 (
                   (procinfo.retdef^.deftype=setdef) and
                   (psetdef(procinfo.retdef)^.settype=smallset)
                 ) then  }
                begin
{$ifdef TEST_FUNCRET }
                   { the space has been set in the local symtable }
                   procinfo.retoffset:=-funcretsym^.address;
                   strdispose(funcretsym^._name);
                   { lowercase name unreachable }
                   { as it is handled differently }
                   funcretsym^._name:=strpnew('func_result');
{$else  TEST_FUNCRET }
                   procinfo.retoffset:=procinfo.firsttemp-procinfo.retdef^.size;
                   procinfo.firsttemp:=procinfo.retoffset;
{$endif TEST_FUNCRET }
                   if (procinfo.flags and pooperator)<>0 then
                     {opsym^.address:=procinfo.call_offset; is wrong PM }
                     opsym^.address:=procinfo.retoffset;
                   { eax is modified by a function }
{$ifdef i386}
                   usedinproc:=usedinproc or ($80 shr byte(R_EAX))
{$endif}
{$ifdef m68k}
                   usedinproc:=usedinproc or ($800 shr word(R_D0))
{$endif}
                end;
           end;

         {Unit initialization?.}
         if (lexlevel=1) then
            if (token=_END) then
                begin
                    consume(_END);
                    block:=nil;
                end
            else
                begin
                    current_module^.flags:=current_module^.flags or
                     uf_init;
                    block:=statement_block;
                end
         else
            block:=statement_block;
      end;

    function assembler_block : ptree;

      begin
         read_declarations(false);
         { temporary space is set, while the BEGIN of the procedure }
         if symtablestack^.symtabletype=localsymtable then
           procinfo.firsttemp := -symtablestack^.datasize
         else procinfo.firsttemp := 0;

         { assembler code does not allocate }
         { space for the return value       }
          if procinfo.retdef<>pdef(voiddef) then
           begin
              if ret_in_acc(procinfo.retdef) then
                begin
                   { in assembler code the result should be directly in %eax
                   procinfo.retoffset:=procinfo.firsttemp-procinfo.retdef^.size;
                   procinfo.firsttemp:=procinfo.retoffset;                   }

{$ifdef i386}
                   usedinproc:=usedinproc or ($80 shr byte(R_EAX))
{$endif}
{$ifdef m68k}
                   usedinproc:=usedinproc or ($800 shr word(R_D0))
{$endif}
                end
              else
              { should we allow assembler functions of big elements ? }
               Message(parser_e_asm_incomp_with_function_return);
           end;
           { set the framepointer to esp for assembler functions }
           { but only if the are no local variables              }
           if ((aktprocsym^.definition^.options and poassembler)<>0) and
              (aktprocsym^.definition^.parast^.datasize=0) and
              (aktprocsym^.definition^.localst^.datasize=0) then
               begin
{$ifdef i386}
                  procinfo.framepointer:=R_ESP;
{$endif}
{$ifdef m68k}
                  procinfo.framepointer:=R_SP;
{$endif}
                  { set the right value for parameters }
                  dec(aktprocsym^.definition^.parast^.call_offset,4);
                  dec(procinfo.call_offset,4);
              end;
            assembler_block:=_asm_statement;
          end;

end.
{
  $Log: pstatmnt.pas,v $
  Revision 1.3.2.1  1998/08/05 14:07:34  pierre
    * changed assembler statement so that a stack frame is generated
      if there are arguments

  Revision 1.3  1998/03/28 23:09:56  florian
    * secondin bugfix (m68k and i386)
    * overflow checking bugfix (m68k and i386) -- pretty useless in
      secondadd, since everything is done using 32-bit
    * loading pointer to routines hopefully fixed (m68k)
    * flags problem with calls to RTL internal routines fixed (still strcmp
      to fix) (m68k)
    * #ELSE was still incorrect (didn't take care of the previous level)
    * problem with filenames in the command line solved
    * problem with mangledname solved
    * linking name problem solved (was case insensitive)
    * double id problem and potential crash solved
    * stop after first error
    * and=>test problem removed
    * correct read for all float types
    * 2 sigsegv fixes and a cosmetic fix for Internal Error
    * push/pop is now correct optimized (=> mov (%esp),reg)

  Revision 1.2  1998/03/26 11:18:31  florian
    - switch -Sa removed
    - support of a:=b:=0 removed

  Revision 1.1.1.1  1998/03/25 11:18:15  root
  * Restored version

  Revision 1.21  1998/03/10 16:27:42  pierre
    * better line info in stabs debug
    * symtabletype and lexlevel separated into two fields of tsymtable
    + ifdef MAKELIB for direct library output, not complete
    + ifdef CHAINPROCSYMS for overloaded seach across units, not fully
      working
    + ifdef TESTFUNCRET for setting func result in underfunction, not
      working

  Revision 1.20  1998/03/10 04:18:26  carl
   * wrong units were being used with m68k target

  Revision 1.19  1998/03/10 01:17:25  peter
    * all files have the same header
    * messages are fully implemented, EXTDEBUG uses Comment()
    + AG... files for the Assembler generation

  Revision 1.18  1998/03/06 00:52:46  peter
    * replaced all old messages from errore.msg, only ExtDebug and some
      Comment() calls are left
    * fixed options.pas

  Revision 1.17  1998/03/02 01:49:07  peter
    * renamed target_DOS to target_GO32V1
    + new verbose system, merged old errors and verbose units into one new
      verbose.pas, so errors.pas is obsolete

  Revision 1.16  1998/02/22 23:03:30  peter
    * renamed msource->mainsource and name->unitname
    * optimized filename handling, filename is not seperate anymore with
      path+name+ext, this saves stackspace and a lot of fsplit()'s
    * recompiling of some units in libraries fixed
    * shared libraries are working again
    + $LINKLIB <lib> to support automatic linking to libraries
    + libraries are saved/read from the ppufile, also allows more libraries
      per ppufile

  Revision 1.15  1998/02/21 03:33:54  carl
    + mit assembler syntax support

  Revision 1.14  1998/02/13 10:35:29  daniel
  * Made Motorola version compilable.
  * Fixed optimizer

  Revision 1.13  1998/02/12 11:50:30  daniel
  Yes! Finally! After three retries, my patch!

  Changes:

  Complete rewrite of psub.pas.
  Added support for DLL's.
  Compiler requires less memory.
  Platform units for each platform.

  Revision 1.12  1998/02/11 21:56:39  florian
    * bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089

  Revision 1.11  1998/02/07 09:39:26  florian
    * correct handling of in_main
    + $D,$T,$X,$V like tp

  Revision 1.10  1998/01/31 00:42:26  carl
    +* Final bugfix #60 (working!) Type checking in case statements

  Revision 1.7  1998/01/21 02:18:28  carl
    * bugfix 79 (assembler_block now chooses the correct framepointer and
      offset).

  Revision 1.6  1998/01/16 22:34:43  michael
  * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
    in this compiler :)

  Revision 1.5  1998/01/12 14:51:18  carl
    - temporariliy removed case type checking until i know where the bug
      comes from!

  Revision 1.4  1998/01/11 19:23:49  carl
    * bug fix number 60 (case statements type checking)

  Revision 1.3  1998/01/11 10:54:25  florian
    + generic library support

  Revision 1.2  1998/01/09 09:10:02  michael
  + Initial implementation, second try

}