freepascal.compiler/compiler/pstatmnt.pas

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

{$i defines.inc}

interface
    uses
      tokens,node;


    function statement_block(starttoken : ttoken) : tnode;

    { reads an assembler block }
    function assembler_block : tnode;


implementation

    uses
       { common }
       cutils,
       { global }
       globtype,globals,verbose,
       systems,cpuinfo,
       { aasm }
       cpubase,aasm,
       { symtable }
       symconst,symbase,symtype,symdef,symsym,symtable,types,
       { pass 1 }
       pass_1,htypechk,
       nbas,nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
       { parser }
       scanner,
       pbase,pexpr,
       { codegen }
       tgcpu,cgbase
{$ifdef i386}
  {$ifndef NoRa386Int}
       ,ra386int
  {$endif NoRa386Int}
  {$ifndef NoRa386Att}
       ,ra386att
  {$endif NoRa386Att}
  {$ifndef NoRa386Dir}
       ,ra386dir
  {$endif NoRa386Dir}
{$endif i386}
{$ifdef m68k}
  {$ifndef NoRa68kMot}
       ,ra68kmot
  {$endif NoRa68kMot}
{$endif m68k}
       { codegen }
{$ifdef newcg}
       ,cgbase
{$endif newcg}
       ;


    function statement : tnode;forward;


    function if_statement : tnode;
      var
         ex,if_a,else_a : tnode;
      begin
         consume(_IF);
         ex:=comp_expr(true);
         consume(_THEN);
         if token<>_ELSE then
           if_a:=statement
         else
           if_a:=nil;

         if try_to_consume(_ELSE) then
            else_a:=statement
         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 : tnode;

      var
         first,last : tstatementnode;

      begin
         first:=nil;
         while token<>_END do
           begin
              if first=nil then
                begin
                   last:=cstatementnode.create(nil,statement);
                   first:=last;
                end
              else
                begin
                   last.left:=cstatementnode.create(nil,statement);
                   last:=tstatementnode(last.left);
                end;
              if not try_to_consume(_SEMICOLON) then
                break;
              consume_emptystats;
           end;
         consume(_END);
         statements_til_end:=cblocknode.create(first);
      end;


    function case_statement : tnode;
      var
         { contains the label number of currently parsed case block }
         aktcaselabel : tasmlabel;
         firstlabel : boolean;
         root : pcaserecord;

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

      procedure newcaselabel(l,h : TConstExprInt;first:boolean);

        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
                  if (hcaselabel^.statement = p^.statement) and
                     (p^._low = hcaselabel^._high + 1) then
                    begin
                      p^._low := hcaselabel^._low;
                      dispose(hcaselabel);
                    end
                  else
                    insertlabel(p^.less)
                else
                  if (p^._high<hcaselabel^._low) and
                     (p^._high<hcaselabel^._high) then
                    if (hcaselabel^.statement = p^.statement) and
                       (p^._high+1 = hcaselabel^._low) then
                      begin
                        p^._high := hcaselabel^._high;
                        dispose(hcaselabel);
                      end
                    else
                      insertlabel(p^.greater)
                  else Message(parser_e_double_caselabel);
          end;

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

      var
         code,caseexpr,p,instruc,elseblock : tnode;
         hl1,hl2 : TConstExprInt;
         casedeferror : boolean;

      begin
         consume(_CASE);
         caseexpr:=comp_expr(true);
       { determines result type }
         cleartempgen;
         do_resulttypepass(caseexpr);
         casedeferror:=false;
         casedef:=caseexpr.resulttype.def;
         if (not assigned(casedef)) or
            not(is_ordinal(casedef)) then
          begin
            CGMessage(type_e_ordinal_expr_expected);
            { create a correct tree }
            caseexpr.free;
            caseexpr:=cordconstnode.create(0,u32bittype);
            { set error flag so no rangechecks are done }
            casedeferror:=true;
          end;

         consume(_OF);
         inc(statement_level);
         root:=nil;
         instruc:=nil;
         repeat
           getlabel(aktcaselabel);
           firstlabel:=true;

           { may be an instruction has more case labels }
           repeat
             p:=expr;
             if is_widechar(casedef) then
               begin
                  if (p.nodetype=rangen) then
                    begin
                       trangenode(p).left:=ctypeconvnode.create(trangenode(p).left,cwidechartype);
                       trangenode(p).right:=ctypeconvnode.create(trangenode(p).right,cwidechartype);
                    end
                  else
                    p:=ctypeconvnode.create(p,cwidechartype);
                  do_resulttypepass(p);
               end;

             hl1:=0;
             hl2:=0;
             if (p.nodetype=rangen) then
               begin
                  { type checking for case statements }
                  if is_subequal(casedef, trangenode(p).left.resulttype.def) and
                     is_subequal(casedef, trangenode(p).right.resulttype.def) then
                    begin
                      hl1:=get_ordinal_value(trangenode(p).left);
                      hl2:=get_ordinal_value(trangenode(p).right);
                      if hl1>hl2 then
                        CGMessage(parser_e_case_lower_less_than_upper_bound);
                      if not casedeferror then
                       begin
                         testrange(casedef,hl1,false);
                         testrange(casedef,hl2,false);
                       end;
                    end
                  else
                    CGMessage(parser_e_case_mismatch);
                  newcaselabel(hl1,hl2,firstlabel);
               end
             else
               begin
                  { type checking for case statements }
                  if not is_subequal(casedef, p.resulttype.def) then
                    CGMessage(parser_e_case_mismatch);
                  hl1:=get_ordinal_value(p);
                  if not casedeferror then
                    testrange(casedef,hl1,false);
                  newcaselabel(hl1,hl1,firstlabel);
               end;
             p.free;
             if token=_COMMA then
               consume(_COMMA)
             else
               break;
             firstlabel:=false;
           until false;
           consume(_COLON);

           { handles instruction block }
           p:=clabelnode.createcase(aktcaselabel,statement);

           { concats instruction }
           instruc:=cstatementnode.create(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 not try_to_consume(_ELSE) then
                consume(_OTHERWISE);
              elseblock:=statements_til_end;
           end
         else
           begin
              elseblock:=nil;
              consume(_END);
           end;
         dec(statement_level);

         code:=ccasenode.create(caseexpr,instruc,root);

         tcasenode(code).elseblock:=elseblock;

         case_statement:=code;
      end;


    function repeat_statement : tnode;

      var
         first,last,p_e : tnode;

      begin
         consume(_REPEAT);
         first:=nil;
         inc(statement_level);

         while token<>_UNTIL do
           begin
              if first=nil then
                begin
                   last:=cstatementnode.create(nil,statement);
                   first:=last;
                end
              else
                begin
                   tstatementnode(last).left:=cstatementnode.create(nil,statement);
                   last:=tstatementnode(last).left;
                end;
              if not try_to_consume(_SEMICOLON) then
                break;
              consume_emptystats;
           end;
         consume(_UNTIL);
         dec(statement_level);

         first:=cblocknode.create(first);
         p_e:=comp_expr(true);
         repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
      end;


    function while_statement : tnode;

      var
         p_e,p_a : tnode;

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


    function for_statement : tnode;

      var
         p_e,tovalue,p_a : tnode;
         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:=comp_expr(true);
         consume(_DO);

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


    function _with_statement : tnode;

      var
         right,p : tnode;
         i,levelcount : longint;
         withsymtable,symtab : tsymtable;
         obj : tobjectdef;
         hp : tnode;
      begin
         p:=comp_expr(true);
         do_resulttypepass(p);
         set_varstate(p,false);
         right:=nil;
         if (not codegenerror) and
            (p.resulttype.def.deftype in [objectdef,recorddef]) then
          begin
            case p.resulttype.def.deftype of
             objectdef : begin
                           obj:=tobjectdef(p.resulttype.def);
                           symtab:=twithsymtable.Create(obj,obj.symtable.symsearch);
                           withsymtable:=symtab;
                           if (p.nodetype=loadn) and
                              (tloadnode(p).symtable=aktprocsym.definition.localst) then
                             twithsymtable(symtab).direct_with:=true;
                           twithsymtable(symtab).withrefnode:=p;
                           levelcount:=1;
                           obj:=obj.childof;
                           while assigned(obj) do
                            begin
                              symtab.next:=twithsymtable.create(obj,obj.symtable.symsearch);
                              symtab:=symtab.next;
                              if (p.nodetype=loadn) and
                                 (tloadnode(p).symtable=aktprocsym.definition.localst) then
                                twithsymtable(symtab).direct_with:=true;
                              twithsymtable(symtab).withrefnode:=p;
                              obj:=obj.childof;
                              inc(levelcount);
                            end;
                           symtab.next:=symtablestack;
                           symtablestack:=withsymtable;
                         end;
             recorddef : begin
                           symtab:=trecorddef(p.resulttype.def).symtable;
                           levelcount:=1;
                           withsymtable:=twithsymtable.create(trecorddef(p.resulttype.def),symtab.symsearch);
                           if (p.nodetype=loadn) and
                              (tloadnode(p).symtable=aktprocsym.definition.localst) then
                           twithsymtable(withsymtable).direct_with:=true;
                           twithsymtable(withsymtable).withrefnode:=p;
                           withsymtable.next:=symtablestack;
                           symtablestack:=withsymtable;
                        end;
            end;
            if token=_COMMA then
             begin
               consume(_COMMA);
               right:=_with_statement{$ifdef FPCPROCVAR}(){$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:=cwithnode.create(twithsymtable(withsymtable),p,right,levelcount);
          end
         else
          begin
            Message(parser_e_false_with_expr);
            { try to recover from error }
            if token=_COMMA then
             begin
               consume(_COMMA);
               hp:=_with_statement{$ifdef FPCPROCVAR}(){$endif};
               if (hp=nil) then; { remove warning about unused }
             end
            else
             begin
               consume(_DO);
               { ignore all }
               if token<>_SEMICOLON then
                statement;
             end;
            _with_statement:=nil;
          end;
      end;


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


    function raise_statement : tnode;

      var
         p,pobj,paddr,pframe : tnode;

      begin
         pobj:=nil;
         paddr:=nil;
         pframe:=nil;
         consume(_RAISE);
         if not(token in [_SEMICOLON,_END]) then
           begin
              { object }
              pobj:=comp_expr(true);
              if try_to_consume(_AT) then
                begin
                   paddr:=comp_expr(true);
                   if try_to_consume(_COMMA) then
                     pframe:=comp_expr(true);
                end;
           end
         else
           begin
              if (block_type<>bt_except) then
                Message(parser_e_no_reraise_possible);
           end;
         p:=craisenode.create(pobj,paddr,pframe);
         raise_statement:=p;
      end;


    function try_statement : tnode;

      var
         p_try_block,p_finally_block,first,last,
         p_default,p_specific,hp : tnode;
         ot : ttype;
         sym : tvarsym;
         old_block_type : tblock_type;
         exceptsymtable : tsymtable;
         objname,objrealname : stringid;
         srsym : tsym;
         srsymtable : tsymtable;
         oldaktexceptblock: integer;

      begin
         procinfo^.flags:=procinfo^.flags or pi_uses_exceptions;

         p_default:=nil;
         p_specific:=nil;

         { read statements to try }
         consume(_TRY);
         first:=nil;
         inc(exceptblockcounter);
         oldaktexceptblock := aktexceptblock;
         aktexceptblock := exceptblockcounter;
         inc(statement_level);

         while (token<>_FINALLY) and (token<>_EXCEPT) do
           begin
              if first=nil then
                begin
                   last:=cstatementnode.create(nil,statement);
                   first:=last;
                end
              else
                begin
                   tstatementnode(last).left:=cstatementnode.create(nil,statement);
                   last:=tstatementnode(last).left;
                end;
              if not try_to_consume(_SEMICOLON) then
                break;
              consume_emptystats;
           end;
         p_try_block:=cblocknode.create(first);

         if try_to_consume(_FINALLY) then
           begin
              inc(exceptblockcounter);
              aktexceptblock := exceptblockcounter;
              p_finally_block:=statements_til_end;
              try_statement:=ctryfinallynode.create(p_try_block,p_finally_block);
              dec(statement_level);
           end
         else
           begin
              consume(_EXCEPT);
              old_block_type:=block_type;
              block_type:=bt_except;
              inc(exceptblockcounter);
              aktexceptblock := exceptblockcounter;
              ot:=generrortype;
              p_specific:=nil;
              if (idtoken=_ON) then
                { catch specific exceptions }
                begin
                   repeat
                     consume(_ID);
                     if token=_ID then
                       begin
                          objname:=pattern;
                          objrealname:=orgpattern;
                          { can't use consume_sym here, because we need already
                            to check for the colon }
                          searchsym(objname,srsym,srsymtable);
                          consume(_ID);
                          { is a explicit name for the exception given ? }
                          if try_to_consume(_COLON) then
                            begin
                               consume_sym(srsym,srsymtable);
                               if (srsym.typ=typesym) and
                                  is_class(ttypesym(srsym).restype.def) then
                                 begin
                                    ot:=ttypesym(srsym).restype;
                                    sym:=tvarsym.create(objrealname,ot);
                                 end
                               else
                                 begin
                                    sym:=tvarsym.create(objrealname,generrortype);
                                    if (srsym.typ=typesym) then
                                      Message1(type_e_class_type_expected,ttypesym(srsym).restype.def.typename)
                                    else
                                      Message1(type_e_class_type_expected,ot.def.typename);
                                 end;
                               exceptsymtable:=tstt_exceptsymtable.create;
                               exceptsymtable.insert(sym);
                               { insert the exception symtable stack }
                               exceptsymtable.next:=symtablestack;
                               symtablestack:=exceptsymtable;
                            end
                          else
                            begin
                               { check if type is valid, must be done here because
                                 with "e: Exception" the e is not necessary }
                               if srsym=nil then
                                begin
                                  identifier_not_found(objrealname);
                                  srsym:=generrorsym;
                                end;
                               { support unit.identifier }
                               if srsym.typ=unitsym then
                                 begin
                                    consume(_POINT);
                                    srsym:=searchsymonlyin(tunitsym(srsym).unitsymtable,pattern);
                                    if srsym=nil then
                                     begin
                                       identifier_not_found(orgpattern);
                                       srsym:=generrorsym;
                                     end;
                                    consume(_ID);
                                 end;
                               { check if type is valid, must be done here because
                                 with "e: Exception" the e is not necessary }
                               if (srsym.typ=typesym) and
                                  is_class(ttypesym(srsym).restype.def) then
                                 ot:=ttypesym(srsym).restype
                               else
                                 begin
                                    ot:=generrortype;
                                    if (srsym.typ=typesym) then
                                      Message1(type_e_class_type_expected,ttypesym(srsym).restype.def.typename)
                                    else
                                      Message1(type_e_class_type_expected,ot.def.typename);
                                 end;
                               exceptsymtable:=nil;
                            end;
                       end
                     else
                       consume(_ID);
                     consume(_DO);
                     hp:=connode.create(nil,statement);
                     if ot.def.deftype=errordef then
                       begin
                          hp.free;
                          hp:=cerrornode.create;
                       end;
                     if p_specific=nil then
                       begin
                          last:=hp;
                          p_specific:=last;
                       end
                     else
                       begin
                          tonnode(last).left:=hp;
                          last:=tonnode(last).left;
                       end;
                     { set the informations }
                     { only if the creation of the onnode was succesful, it's possible }
                     { that last and hp are errornodes (JM)                            }
                     if last.nodetype = onn then
                       begin
                         tonnode(last).excepttype:=tobjectdef(ot.def);
                         tonnode(last).exceptsymtable:=exceptsymtable;
                       end;
                     { remove exception symtable }
                     if assigned(exceptsymtable) then
                       begin
                         dellexlevel;
                         if last.nodetype <> onn then
                           exceptsymtable.free;
                       end;
                     if not try_to_consume(_SEMICOLON) then
                        break;
                     consume_emptystats;
                   until (token=_END) or (token=_ELSE);
                   if token=_ELSE then
                     { catch the other exceptions }
                     begin
                        consume(_ELSE);
                        p_default:=statements_til_end;
                     end
                   else
                     consume(_END);
                end
              else
                { catch all exceptions }
                begin
                   p_default:=statements_til_end;
                end;
              dec(statement_level);

              block_type:=old_block_type;
              try_statement:=ctryexceptnode.create(p_try_block,p_specific,p_default);
           end;
         aktexceptblock := oldaktexceptblock;
      end;


    function exit_statement : tnode;

      var
         p : tnode;

      begin
         consume(_EXIT);
         if try_to_consume(_LKLAMMER) then
           begin
              p:=comp_expr(true);
              consume(_RKLAMMER);
              if (block_type=bt_except) then
                Message(parser_e_exit_with_argument_not__possible);
              if is_void(aktprocsym.definition.rettype.def) then
                Message(parser_e_void_function);
           end
         else
           p:=nil;
         p:=cexitnode.create(p);
         do_resulttypepass(p);
         exit_statement:=p;
      end;


    function _asm_statement : tnode;
      var
        asmstat : tasmnode;
        Marker : tai;
      begin
         Inside_asm_statement:=true;
         case aktasmmode of
           asmmode_none : ; { just be there to allow to a compile without
                              any assembler readers }
{$ifdef i386}
  {$ifndef NoRA386Att}
           asmmode_i386_att:
             asmstat:=tasmnode(ra386att.assemble);
  {$endif NoRA386Att}
  {$ifndef NoRA386Int}
           asmmode_i386_intel:
             asmstat:=tasmnode(ra386int.assemble);
  {$endif NoRA386Int}
  {$ifndef NoRA386Dir}
           asmmode_i386_direct:
             begin
               if not target_asm.allowdirect then
                 Message(parser_f_direct_assembler_not_allowed);
               if (pocall_inline in aktprocsym.definition.proccalloptions) then
                 Begin
                    Message1(parser_w_not_supported_for_inline,'direct asm');
                    Message(parser_w_inlining_disabled);
                    exclude(aktprocsym.definition.proccalloptions,pocall_inline);
                 End;
               asmstat:=tasmnode(ra386dir.assemble);
             end;
  {$endif NoRA386Dir}
{$endif}
{$ifdef m68k}
  {$ifndef NoRA68kMot}
           asmmode_m68k_mot:
             asmstat:=tasmnode(ra68kmot.assemble);
  {$endif NoRA68kMot}
{$endif}
         else
           Message(parser_f_assembler_reader_not_supported);
         end;

         { Read first the _ASM statement }
         consume(_ASM);

{$ifndef newcg}
         { END is read }
         if try_to_consume(_LECKKLAMMER) then
           begin
              { it's possible to specify the modified registers }
              include(asmstat.flags,nf_object_preserved);
              if token<>_RECKKLAMMER then
                repeat
                { uppercase, because it's a CSTRING }
                  uppervar(pattern);
{$ifdef i386}
                  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
                    begin
                       usedinproc:=usedinproc or ($80 shr byte(R_ESI));
                       exclude(asmstat.flags,nf_object_preserved);
                    end
                  else if pattern='EDI' then
                    usedinproc:=usedinproc or ($80 shr byte(R_EDI))
{$endif i386}
{$ifdef m68k}
                  if pattern='D0' then
                    usedinproc:=usedinproc +[R_D0]
                  else if pattern='D1' then
                    usedinproc:=usedinproc + [R_D1]
                  else if pattern='D2' then
                    usedinproc:=usedinproc + [R_D2]
                  else if pattern='D3' then
                    usedinproc:=usedinproc + [R_D3]
                  else if pattern='D4' then
                    usedinproc:=usedinproc + [R_D4]
                  else if pattern='D5' then
                    usedinproc:=usedinproc + [R_D5]
                  else if pattern='D6' then
                    usedinproc:=usedinproc + [R_D6]
                  else if pattern='D7' then
                    usedinproc:=usedinproc + [R_D7]
                  else if pattern='A0' then
                    usedinproc:=usedinproc + [R_A0]
                  else if pattern='A1' then
                    usedinproc:=usedinproc + [R_A1]
                  else if pattern='A2' then
                    usedinproc:=usedinproc + [R_A2]
                  else if pattern='A3' then
                    usedinproc:=usedinproc + [R_A3]
                  else if pattern='A4' then
                    usedinproc:=usedinproc + [R_A4]
                  else if pattern='A5' then
                    usedinproc:=usedinproc + [R_A5]
{$endif m68k}
{$ifdef powerpc}
                  if pattern<>'' then
                    internalerror(200108251)
{$endif powerpc}
                  else consume(_RECKKLAMMER);
                  consume(_CSTRING);
                  if not try_to_consume(_COMMA) then
                    break;
                until false;
              consume(_RECKKLAMMER);
           end
{$ifdef i386}
         else usedinproc:=$ff;
{$else}
{$ifdef powerpc}
         else usedinproc := 0;
{$else powerpc}
         else usedinproc := ALL_REGISTERS;
{$endif powerpc}
{$endif i386}
{$endif newcg}

         { mark the start and the end of the assembler block
           this is needed for the optimizer }
         If Assigned(AsmStat.p_asm) Then
           Begin
             Marker := Tai_Marker.Create(AsmBlockStart);
             AsmStat.p_asm.Insert(Marker);
             Marker := Tai_Marker.Create(AsmBlockEnd);
             AsmStat.p_asm.Concat(Marker);
           End;
         Inside_asm_statement:=false;
         _asm_statement:=asmstat;
      end;


    function new_dispose_statement : tnode;
      var
        p,p2     : tnode;
        again    : boolean; { dummy for do_proc_call }
        destructorname : stringid;
        sym      : tsym;
        classh   : tobjectdef;
        destructorpos,
        storepos : tfileposinfo;
        is_new   : boolean;
      begin
        if try_to_consume(_NEW) then
          is_new:=true
        else
          begin
            consume(_DISPOSE);
            is_new:=false;
          end;
        consume(_LKLAMMER);
        p:=comp_expr(true);
        { calc return type }
        cleartempgen;
        set_varstate(p,(not is_new));
        { constructor,destructor specified }
        if try_to_consume(_COMMA) then
          begin
            { extended syntax of new and dispose }
            { function styled new is handled in factor }
            { destructors have no parameters }
            destructorname:=pattern;
            destructorpos:=akttokenpos;
            consume(_ID);

            if (p.resulttype.def.deftype<>pointerdef) then
              begin
                 Message1(type_e_pointer_type_expected,p.resulttype.def.typename);
                 p.free;
                 p:=factor(false);
                 p.free;
                 consume(_RKLAMMER);
                 new_dispose_statement:=cerrornode.create;
                 exit;
              end;
            { first parameter must be an object or class }
            if tpointerdef(p.resulttype.def).pointertype.def.deftype<>objectdef then
              begin
                 Message(parser_e_pointer_to_class_expected);
                 p.free;
                 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:=tobjectdef(tpointerdef(p.resulttype.def).pointertype.def);
            if is_class(classh) then
              begin
                 Message(parser_e_no_new_or_dispose_for_classes);
                 new_dispose_statement:=factor(false);
                 consume_all_until(_RKLAMMER);
                 consume(_RKLAMMER);
                 exit;
              end;
            { search cons-/destructor, also in parent classes }
            storepos:=akttokenpos;
            akttokenpos:=destructorpos;
            sym:=search_class_member(classh,destructorname);
            akttokenpos:=storepos;

            { the second parameter of new/dispose must be a call }
            { to a cons-/destructor                              }
            if (not assigned(sym)) or (sym.typ<>procsym) then
              begin
                 if is_new then
                  Message(parser_e_expr_have_to_be_constructor_call)
                 else
                  Message(parser_e_expr_have_to_be_destructor_call);
                 p.free;
                 new_dispose_statement:=cerrornode.create;
              end
            else
              begin
                if is_new then
                 p2:=chnewnode.create
                else
                 p2:=chdisposenode.create(p);
                do_resulttypepass(p2);
                p2.resulttype:=tpointerdef(p.resulttype.def).pointertype;
                if is_new then
                  do_member_read(false,sym,p2,again)
                else
                  begin
                    if (m_tp in aktmodeswitches) then
                      do_member_read(false,sym,p2,again)
                    else
                      begin
                        p2:=ccallnode.create(nil,tprocsym(sym),sym.owner,p2);
                        { support dispose(p,done()); }
                        if try_to_consume(_LKLAMMER) then
                          begin
                            if not try_to_consume(_RKLAMMER) then
                              begin
                                Message(parser_e_no_paras_for_destructor);
                                consume_all_until(_RKLAMMER);
                                consume(_RKLAMMER);
                              end;
                          end;
                      end;
                  end;

                { we need the real called method }
                cleartempgen;
                do_resulttypepass(p2);
                if not codegenerror then
                 begin
                   if is_new then
                    begin
                      if (tcallnode(p2).procdefinition.proctypeoption<>potype_constructor) then
                        Message(parser_e_expr_have_to_be_constructor_call);
                      p2:=cnewnode.create(p2);
                      do_resulttypepass(p2);
                      p2.resulttype:=p.resulttype;
                      p2:=cassignmentnode.create(p,p2);
                    end
                   else
                    begin
                      if (tcallnode(p2).procdefinition.proctypeoption<>potype_destructor) then
                        Message(parser_e_expr_have_to_be_destructor_call);
                    end;
                 end;
                new_dispose_statement:=p2;
              end;
          end
        else
          begin
             if (p.resulttype.def.deftype<>pointerdef) then
               Begin
                  Message1(type_e_pointer_type_expected,p.resulttype.def.typename);
                  new_dispose_statement:=cerrornode.create;
               end
             else
               begin
                  if (tpointerdef(p.resulttype.def).pointertype.def.deftype=objectdef) and
                     (oo_has_vmt in tobjectdef(tpointerdef(p.resulttype.def).pointertype.def).objectoptions) then
                    Message(parser_w_use_extended_syntax_for_objects);
                  if (tpointerdef(p.resulttype.def).pointertype.def.deftype=orddef) and
                     (torddef(tpointerdef(p.resulttype.def).pointertype.def).typ=uvoid) then
                    begin
                      if (m_tp in aktmodeswitches) or
                         (m_delphi in aktmodeswitches) then
                       Message(parser_w_no_new_dispose_on_void_pointers)
                      else
                       Message(parser_e_no_new_dispose_on_void_pointers);
                    end;

                  if is_new then
                    new_dispose_statement:=csimplenewdisposenode.create(simplenewn,p)
                  else
                    new_dispose_statement:=csimplenewdisposenode.create(simpledisposen,p);
               end;
          end;
        consume(_RKLAMMER);
      end;


    function statement : tnode;
      var
         p       : tnode;
         code    : tnode;
         filepos : tfileposinfo;
         srsym   : tsym;
         srsymtable : tsymtable;
      begin
         filepos:=akttokenpos;
         case token of
           _GOTO :
             begin
                if not(cs_support_goto in aktmoduleswitches)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:=cerrornode.create;
                  end
                else
                  begin
                     consume_sym(srsym,srsymtable);
                     if srsym.typ<>labelsym then
                       begin
                          Message(sym_e_id_is_no_label_id);
                          code:=cerrornode.create;
                       end
                     else
                       begin
                         code:=cgotonode.create(tlabelsym(srsym));
                         tgotonode(code).labsym:=tlabelsym(srsym);
                         { set flag that this label is used }
                         tlabelsym(srsym).used:=true;
                       end;
                  end;
             end;
           _BEGIN :
             code:=statement_block(_BEGIN);
           _IF :
             code:=if_statement;
           _CASE :
             code:=case_statement;
           _REPEAT :
             code:=repeat_statement;
           _WHILE :
             code:=while_statement;
           _FOR :
             code:=for_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:=cnothingnode.create;
           _FAIL :
             begin
                if (aktprocsym.definition.proctypeoption<>potype_constructor) then
                  Message(parser_e_fail_only_in_constructor);
                consume(_FAIL);
                code:=cfailnode.create;
             end;
           _EXIT :
             code:=exit_statement;
           _ASM :
             code:=_asm_statement;
           _EOF :
             Message(scan_f_end_of_file);
         else
           begin
              if (idtoken=_NEW) or (idtoken=_DISPOSE) then
                code:=new_dispose_statement
              else
                begin
                   p:=expr;

                   if p.nodetype=labeln then
                    begin
                      { the pointer to the following instruction }
                      { isn't a very clean way                   }
                      tlabelnode(p).left:=statement{$ifdef FPCPROCVAR}(){$endif};
                      { be sure to have left also resulttypepass }
                      resulttypepass(tlabelnode(p).left);
                    end;

                   { blockn support because a read/write is changed into a blocknode }
                   { with a separate statement for each read/write operation (JM)    }
                   { the same is true for val() if the third parameter is not 32 bit }
                   if not(p.nodetype in [calln,assignn,breakn,inlinen,continuen,labeln,blockn]) then
                     Message(cg_e_illegal_expression);
                   { specify that we don't use the value returned by the call }
                   { Question : can this be also improtant
                     for inlinen ??
                     it is used for :
                      - dispose of temp stack space
                      - dispose on FPU stack }
                   if p.nodetype=calln then
                     exclude(p.flags,nf_return_value_used);
                   code:=p;
                end;
           end;
         end;
         if assigned(code) then
          code.set_tree_filepos(filepos);
         statement:=code;
      end;


    function statement_block(starttoken : ttoken) : tnode;

      var
         first,last : tnode;
         filepos : tfileposinfo;

      begin
         first:=nil;
         filepos:=akttokenpos;
         consume(starttoken);
         inc(statement_level);

         while not(token in [_END,_FINALIZATION]) do
           begin
              if first=nil then
                begin
                   last:=cstatementnode.create(nil,statement);
                   first:=last;
                end
              else
                begin
                   tstatementnode(last).left:=cstatementnode.create(nil,statement);
                   last:=tstatementnode(last).left;
                end;
              if (token in [_END,_FINALIZATION]) then
                break
              else
                begin
                   { if no semicolon, then error and go on }
                   if token<>_SEMICOLON then
                     begin
                        consume(_SEMICOLON);
                        consume_all_until(_SEMICOLON);
                     end;
                   consume(_SEMICOLON);
                end;
              consume_emptystats;
           end;

         { don't consume the finalization token, it is consumed when
           reading the finalization block, but allow it only after
           an initalization ! }
         if (starttoken<>_INITIALIZATION) or (token<>_FINALIZATION) then
           consume(_END);

         dec(statement_level);

         last:=cblocknode.create(first);
         last.set_tree_filepos(filepos);
         statement_block:=last;
      end;


    function assembler_block : tnode;

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

         { assembler code does not allocate }
         { space for the return value       }
          if not is_void(aktprocsym.definition.rettype.def) then
           begin
              aktprocsym.definition.funcretsym:=tfuncretsym.create(aktprocsym.name,aktprocsym.definition.rettype);
              if ret_in_acc(aktprocsym.definition.rettype.def) then
                begin
                   { in assembler code the result should be directly in %eax
                   procinfo^.retoffset:=procinfo^.firsttemp-procinfo^.retdef.size;
                   procinfo^.firsttemp:=procinfo^.retoffset;                 }

{$ifndef newcg}
{$ifdef i386}
                   usedinproc:=usedinproc or ($80 shr byte(R_EAX))
{$else}
{$ifdef POWERPC}
                   usedinproc:=0;
{$else POWERPC}
                   usedinproc:=usedinproc + [accumulator];
{$endif POWERPC}
{$endif i386}
{$endif newcg}
                end
              {
              else if not is_fpu(procinfo^.retdef) then
               should we allow assembler functions of big elements ?
                YES (FK)!!
               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           }
           { added no parameter also (PM)                       }
           { disable for methods, because self pointer is expected }
           { at -8(%ebp) (JM)                                      }
           { why if se use %esp then self is still at the correct address PM }
           if {not(assigned(procinfo^._class)) and}
              (po_assembler in aktprocsym.definition.procoptions) and
              (aktprocsym.definition.localst.datasize=0) and
              (aktprocsym.definition.parast.datasize=0) and
              not(ret_in_param(aktprocsym.definition.rettype.def)) then
             begin
               procinfo^.framepointer:=stack_pointer;
               { set the right value for parameters }
               dec(aktprocsym.definition.parast.address_fixup,target_info.size_of_pointer);
               dec(procinfo^.para_offset,target_info.size_of_pointer);
             end;
          { only insert now in the symtable, otherwise the              }
          { "aktprocsym.definition.localst.datasize=0" check above will }
          { always fail (JM)                                            }
          if not is_void(aktprocsym.definition.rettype.def) then
            begin
              { insert in local symtable }
              symtablestack.insert(aktprocsym.definition.funcretsym);
            end;
          { force the asm statement }
            if token<>_ASM then
             consume(_ASM);
            procinfo^.Flags := procinfo^.Flags Or pi_is_assembler;
            assembler_block:=_asm_statement;
          { becuase the END is already read we need to get the
            last_endtoken_filepos here (PFV) }
            last_endtoken_filepos:=akttokenpos;
          end;

end.
{
  $Log$
  Revision 1.39  2001-10-17 22:41:04  florian
    * several widechar fixes, case works now

  Revision 1.38  2001/10/16 15:10:35  jonas
    * fixed goto/label/try bugs

  Revision 1.37  2001/09/22 11:11:43  peter
    * "fpc -P?" command to query for used ppcXXX compiler

  Revision 1.36  2001/09/06 10:21:50  jonas
    * fixed superfluous generation of stackframes for assembler procedures
      with no local vars or para's (this broke the backtrace printing in case
      of an rte)

  Revision 1.35  2001/09/03 13:19:12  jonas
    * set funcretsym for assembler procedures too (otherwise using __RESULT
      in assembler procedures causes a crash)

  Revision 1.34  2001/08/26 13:36:46  florian
    * some cg reorganisation
    * some PPC updates

  Revision 1.33  2001/08/23 14:28:36  jonas
    + tempcreate/ref/delete nodes (allows the use of temps in the
      resulttype and first pass)
    * made handling of read(ln)/write(ln) processor independent
    * moved processor independent handling for str and reset/rewrite-typed
      from firstpass to resulttype pass
    * changed names of helpers in text.inc to be generic for use as
      compilerprocs + added "iocheck" directive for most of them
    * reading of ordinals is done by procedures instead of functions
      because otherwise FPC_IOCHECK overwrote the result before it could
      be stored elsewhere (range checking still works)
    * compilerprocs can now be used in the system unit before they are
      implemented
    * added note to errore.msg that booleans can't be read using read/readln

  Revision 1.32  2001/08/06 21:40:47  peter
    * funcret moved from tprocinfo to tprocdef

  Revision 1.31  2001/06/03 21:57:37  peter
    + hint directive parsing support

  Revision 1.30  2001/05/17 13:25:24  jonas
    * fixed web bugs 1480 and 1481

  Revision 1.29  2001/05/04 15:52:04  florian
    * some Delphi incompatibilities fixed:
       - out, dispose and new can be used as idenfiers now
       - const p = apointerype(nil); is supported now
    + support for const p = apointertype(pointer(1234)); added

  Revision 1.28  2001/04/21 12:03:11  peter
    * m68k updates merged from fixes branch

  Revision 1.27  2001/04/18 22:01:57  peter
    * registration of targets and assemblers

  Revision 1.26  2001/04/15 09:48:30  peter
    * fixed crash in labelnode
    * easier detection of goto and label in try blocks

  Revision 1.25  2001/04/14 14:07:11  peter
    * moved more code from pass_1 to det_resulttype

  Revision 1.24  2001/04/13 01:22:13  peter
    * symtable change to classes
    * range check generation and errors fixed, make cycle DEBUG=1 works
    * memory leaks fixed

  Revision 1.23  2001/04/04 22:43:52  peter
    * remove unnecessary calls to firstpass

  Revision 1.22  2001/04/02 21:20:34  peter
    * resulttype rewrite

  Revision 1.21  2001/03/22 22:35:42  florian
    + support for type a = (a=1); in Delphi mode added
    + procedure p(); in Delphi mode supported
    + on isn't keyword anymore, it can be used as
      id etc. now

  Revision 1.20  2001/03/11 22:58:50  peter
    * getsym redesign, removed the globals srsym,srsymtable

  Revision 1.19  2000/12/25 00:07:27  peter
    + new tlinkedlist class (merge of old tstringqueue,tcontainer and
      tlinkedlist objects)

  Revision 1.18  2000/12/23 19:59:35  peter
    * object to class for ow/og objects
    * split objectdata from objectoutput

  Revision 1.17  2000/12/16 22:45:55  jonas
    * fixed case statements with int64 values

  Revision 1.16  2000/11/29 00:30:37  florian
    * unused units removed from uses clause
    * some changes for widestrings

  Revision 1.15  2000/11/27 15:47:19  jonas
    * fix for web bug 1251 (example 1)

  Revision 1.14  2000/11/22 22:43:34  peter
    * fixed crash with exception without sysutils (merged)

  Revision 1.13  2000/11/04 14:25:21  florian
    + merged Attila's changes for interfaces, not tested yet

  Revision 1.12  2000/10/31 22:02:50  peter
    * symtable splitted, no real code changes

  Revision 1.11  2000/10/14 21:52:56  peter
    * fixed memory leaks

  Revision 1.10  2000/10/14 10:14:52  peter
    * moehrendorf oct 2000 rewrite

  Revision 1.9  2000/10/01 19:48:25  peter
    * lot of compile updates for cg11

  Revision 1.8  2000/09/24 21:19:50  peter
    * delphi compile fixes

  Revision 1.7  2000/09/24 15:06:24  peter
    * use defines.inc

  Revision 1.6  2000/08/27 16:11:52  peter
    * moved some util functions from globals,cobjects to cutils
    * splitted files into finput,fmodule

  Revision 1.5  2000/08/12 15:41:15  peter
    * fixed bug 1096 (merged)

  Revision 1.4  2000/08/12 06:46:06  florian
    + case statement for int64/qword implemented

  Revision 1.3  2000/07/13 12:08:27  michael
  + patched to 1.1.0 with former 1.09patch from peter

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

}