development/compilers/freepascal/compiler/pstatmnt.pas

   1 {
   2     $Id$
   3     Copyright (c) 1998-2000 by Florian Klaempfl
   4
   5     Does the parsing of the statements
   6
   7     This program is free software; you can redistribute it and/or modify
   8     it under the terms of the GNU General Public License as published by
   9     the Free Software Foundation; either version 2 of the License, or
  10     (at your option) any later version.
  11
  12     This program is distributed in the hope that it will be useful,
  13     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15     GNU General Public License for more details.
  16
  17     You should have received a copy of the GNU General Public License
  18     along with this program; if not, write to the Free Software
  19     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21  ****************************************************************************
  22 }
  23 {$ifdef FPC}
  24   {$goto on}
  25 {$endif FPC}
  26
  27 unit pstatmnt;
  28
  29   interface
  30
  31     uses tree;
  32
  33     { reads a block }
  34     function block(islibrary : boolean) : ptree;
  35
  36     { reads an assembler block }
  37     function assembler_block : ptree;
  38
  39   implementation
  40
  41     uses
  42        globtype,systems,tokens,
  43        strings,cobjects,globals,files,verbose,
  44        symconst,symtable,aasm,pass_1,types,scanner,
  45 {$ifdef newcg}
  46        cgbase,
  47 {$else}
  48        hcodegen,
  49 {$endif}
  50        ppu
  51        ,pbase,pexpr,pdecl,cpubase,cpuasm
  52 {$ifdef i386}
  53        ,tgeni386
  54   {$ifndef NoRa386Int}
  55        ,ra386int
  56   {$endif NoRa386Int}
  57   {$ifndef NoRa386Att}
  58        ,ra386att
  59   {$endif NoRa386Att}
  60   {$ifndef NoRa386Dir}
  61        ,ra386dir
  62   {$endif NoRa386Dir}
  63 {$endif i386}
  64 {$ifdef m68k}
  65        ,tgen68k
  66   {$ifndef NoRa68kMot}
  67        ,ra68kmot
  68   {$endif NoRa68kMot}
  69 {$endif m68k}
  70 {$ifdef alpha}
  71        ,tgeni386  { this is a dummy!! }
  72 {$endif alpha}
  73 {$ifdef powerpc}
  74        ,tgeni386  { this is a dummy!! }
  75 {$endif powerpc}
  76        ;
  77
  78
  79     const
  80       statement_level : longint = 0;
  81
  82     function statement : ptree;forward;
  83
  84
  85     function if_statement : ptree;
  86       var
  87          ex,if_a,else_a : ptree;
  88       begin
  89          consume(_IF);
  90          ex:=comp_expr(true);
  91          consume(_THEN);
  92          if token<>_ELSE then
  93            if_a:=statement
  94          else
  95            if_a:=nil;
  96
  97          if try_to_consume(_ELSE) then
  98             else_a:=statement
  99          else
 100            else_a:=nil;
 101          if_statement:=genloopnode(ifn,ex,if_a,else_a,false);
 102       end;
 103
 104     { creates a block (list) of statements, til the next END token }
 105     function statements_til_end : ptree;
 106
 107       var
 108          first,last : ptree;
 109
 110       begin
 111          first:=nil;
 112          while token<>_END do
 113            begin
 114               if first=nil then
 115                 begin
 116                    last:=gennode(statementn,nil,statement);
 117                    first:=last;
 118                 end
 119               else
 120                 begin
 121                    last^.left:=gennode(statementn,nil,statement);
 122                    last:=last^.left;
 123                 end;
 124               if not try_to_consume(_SEMICOLON) then
 125                 break;
 126               emptystats;
 127            end;
 128          consume(_END);
 129          statements_til_end:=gensinglenode(blockn,first);
 130       end;
 131
 132     function case_statement : ptree;
 133
 134       var
 135          { contains the label number of currently parsed case block }
 136          aktcaselabel : pasmlabel;
 137          firstlabel : boolean;
 138          root : pcaserecord;
 139
 140          { the typ of the case expression }
 141          casedef : pdef;
 142
 143       procedure newcaselabel(l,h : longint;first:boolean);
 144
 145         var
 146            hcaselabel : pcaserecord;
 147
 148         procedure insertlabel(var p : pcaserecord);
 149
 150           begin
 151              if p=nil then p:=hcaselabel
 152              else
 153                 if (p^._low>hcaselabel^._low) and
 154                    (p^._low>hcaselabel^._high) then
 155                   if (hcaselabel^.statement = p^.statement) and
 156                      (p^._low = hcaselabel^._high + 1) then
 157                     begin
 158                       p^._low := hcaselabel^._low;
 159                       dispose(hcaselabel);
 160                     end
 161                   else
 162                     insertlabel(p^.less)
 163                 else
 164                   if (p^._high<hcaselabel^._low) and
 165                      (p^._high<hcaselabel^._high) then
 166                     if (hcaselabel^.statement = p^.statement) and
 167                        (p^._high+1 = hcaselabel^._low) then
 168                       begin
 169                         p^._high := hcaselabel^._high;
 170                         dispose(hcaselabel);
 171                       end
 172                     else
 173                       insertlabel(p^.greater)
 174                   else Message(parser_e_double_caselabel);
 175           end;
 176
 177         begin
 178            new(hcaselabel);
 179            hcaselabel^.less:=nil;
 180            hcaselabel^.greater:=nil;
 181            hcaselabel^.statement:=aktcaselabel;
 182            hcaselabel^.firstlabel:=first;
 183            getlabel(hcaselabel^._at);
 184            hcaselabel^._low:=l;
 185            hcaselabel^._high:=h;
 186            insertlabel(root);
 187         end;
 188
 189       var
 190          code,caseexpr,p,instruc,elseblock : ptree;
 191          hl1,hl2 : longint;
 192          casedeferror : boolean;
 193       begin
 194          consume(_CASE);
 195          caseexpr:=comp_expr(true);
 196        { determines result type }
 197          cleartempgen;
 198          do_firstpass(caseexpr);
 199          casedeferror:=false;
 200          casedef:=caseexpr^.resulttype;
 201          if (not assigned(casedef)) or
 202             not(is_ordinal(casedef) or is_64bitint(casedef)) then
 203           begin
 204             CGMessage(type_e_ordinal_expr_expected);
 205             { create a correct tree }
 206             disposetree(caseexpr);
 207             caseexpr:=genordinalconstnode(0,u32bitdef);
 208             { set error flag so no rangechecks are done }
 209             casedeferror:=true;
 210           end;
 211
 212          consume(_OF);
 213          inc(statement_level);
 214          root:=nil;
 215          instruc:=nil;
 216          repeat
 217            getlabel(aktcaselabel);
 218            firstlabel:=true;
 219
 220            { may be an instruction has more case labels }
 221            repeat
 222              p:=expr;
 223              cleartempgen;
 224              do_firstpass(p);
 225              hl1:=0;
 226              hl2:=0;
 227              if (p^.treetype=rangen) then
 228                begin
 229                   { type checking for case statements }
 230                   if is_subequal(casedef, p^.left^.resulttype) and
 231                      is_subequal(casedef, p^.right^.resulttype) then
 232                     begin
 233                       hl1:=get_ordinal_value(p^.left);
 234                       hl2:=get_ordinal_value(p^.right);
 235                       if hl1>hl2 then
 236                         CGMessage(parser_e_case_lower_less_than_upper_bound);
 237                       if not casedeferror then
 238                        begin
 239                          testrange(casedef,hl1);
 240                          testrange(casedef,hl2);
 241                        end;
 242                     end
 243                   else
 244                     CGMessage(parser_e_case_mismatch);
 245                   newcaselabel(hl1,hl2,firstlabel);
 246                end
 247              else
 248                begin
 249                   { type checking for case statements }
 250                   if not is_subequal(casedef, p^.resulttype) then
 251                     CGMessage(parser_e_case_mismatch);
 252                   hl1:=get_ordinal_value(p);
 253                   if not casedeferror then
 254                     testrange(casedef,hl1);
 255                   newcaselabel(hl1,hl1,firstlabel);
 256                end;
 257              disposetree(p);
 258              if token=_COMMA then
 259                consume(_COMMA)
 260              else
 261                break;
 262              firstlabel:=false;
 263            until false;
 264            consume(_COLON);
 265
 266            { handles instruction block }
 267            p:=gensinglenode(labeln,statement);
 268            p^.labelnr:=aktcaselabel;
 269
 270            { concats instruction }
 271            instruc:=gennode(statementn,instruc,p);
 272
 273            if not((token=_ELSE) or (token=_OTHERWISE) or (token=_END)) then
 274              consume(_SEMICOLON);
 275          until (token=_ELSE) or (token=_OTHERWISE) or (token=_END);
 276
 277          if (token=_ELSE) or (token=_OTHERWISE) then
 278            begin
 279               if not try_to_consume(_ELSE) then
 280                 consume(_OTHERWISE);
 281               elseblock:=statements_til_end;
 282            end
 283          else
 284            begin
 285               elseblock:=nil;
 286               consume(_END);
 287            end;
 288          dec(statement_level);
 289
 290          code:=gencasenode(caseexpr,instruc,root);
 291
 292          code^.elseblock:=elseblock;
 293
 294          case_statement:=code;
 295       end;
 296
 297
 298     function repeat_statement : ptree;
 299
 300       var
 301          first,last,p_e : ptree;
 302
 303       begin
 304          consume(_REPEAT);
 305          first:=nil;
 306          inc(statement_level);
 307
 308          while token<>_UNTIL do
 309            begin
 310               if first=nil then
 311                 begin
 312                    last:=gennode(statementn,nil,statement);
 313                    first:=last;
 314                 end
 315               else
 316                 begin
 317                    last^.left:=gennode(statementn,nil,statement);
 318                    last:=last^.left;
 319                 end;
 320               if not try_to_consume(_SEMICOLON) then
 321                 break;
 322               emptystats;
 323            end;
 324          consume(_UNTIL);
 325          dec(statement_level);
 326
 327          first:=gensinglenode(blockn,first);
 328          p_e:=comp_expr(true);
 329          repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
 330       end;
 331
 332
 333     function while_statement : ptree;
 334
 335       var
 336          p_e,p_a : ptree;
 337
 338       begin
 339          consume(_WHILE);
 340          p_e:=comp_expr(true);
 341          consume(_DO);
 342          p_a:=statement;
 343          while_statement:=genloopnode(whilen,p_e,p_a,nil,false);
 344       end;
 345
 346
 347     function for_statement : ptree;
 348
 349       var
 350          p_e,tovalue,p_a : ptree;
 351          backward : boolean;
 352
 353       begin
 354          { parse loop header }
 355          consume(_FOR);
 356          p_e:=expr;
 357          if token=_DOWNTO then
 358            begin
 359               consume(_DOWNTO);
 360               backward:=true;
 361            end
 362          else
 363            begin
 364               consume(_TO);
 365               backward:=false;
 366            end;
 367          tovalue:=comp_expr(true);
 368          consume(_DO);
 369
 370          { ... now the instruction }
 371          p_a:=statement;
 372          for_statement:=genloopnode(forn,p_e,tovalue,p_a,backward);
 373       end;
 374
 375
 376     function _with_statement : ptree;
 377
 378       var
 379          right,p : ptree;
 380          i,levelcount : longint;
 381          withsymtable,symtab : psymtable;
 382          obj : pobjectdef;
 383 {$ifdef tp}
 384          hp : ptree;
 385 {$endif}
 386       begin
 387          p:=comp_expr(true);
 388          do_firstpass(p);
 389          set_varstate(p,false);
 390          right:=nil;
 391          if (not codegenerror) and
 392             (p^.resulttype^.deftype in [objectdef,recorddef]) then
 393           begin
 394             case p^.resulttype^.deftype of
 395              objectdef : begin
 396                            obj:=pobjectdef(p^.resulttype);
 397                            withsymtable:=new(pwithsymtable,init);
 398                            withsymtable^.symsearch:=obj^.symtable^.symsearch;
 399                            withsymtable^.defowner:=obj;
 400                            symtab:=withsymtable;
 401                            if (p^.treetype=loadn) and
 402                               (p^.symtable=aktprocsym^.definition^.localst) then
 403                              pwithsymtable(symtab)^.direct_with:=true;
 404                            {symtab^.withnode:=p; not yet allocated !! }
 405                            pwithsymtable(symtab)^.withrefnode:=p;
 406                            levelcount:=1;
 407                            obj:=obj^.childof;
 408                            while assigned(obj) do
 409                             begin
 410                               symtab^.next:=new(pwithsymtable,init);
 411                               symtab:=symtab^.next;
 412                               symtab^.symsearch:=obj^.symtable^.symsearch;
 413                               if (p^.treetype=loadn) and
 414                                  (p^.symtable=aktprocsym^.definition^.localst) then
 415                                 pwithsymtable(symtab)^.direct_with:=true;
 416                               {symtab^.withnode:=p; not yet allocated !! }
 417                               pwithsymtable(symtab)^.withrefnode:=p;
 418                               symtab^.defowner:=obj;
 419                               obj:=obj^.childof;
 420                               inc(levelcount);
 421                             end;
 422                            symtab^.next:=symtablestack;
 423                            symtablestack:=withsymtable;
 424                          end;
 425              recorddef : begin
 426                            symtab:=precorddef(p^.resulttype)^.symtable;
 427                            levelcount:=1;
 428                            withsymtable:=new(pwithsymtable,init);
 429                            withsymtable^.symsearch:=symtab^.symsearch;
 430                            withsymtable^.next:=symtablestack;
 431                               if (p^.treetype=loadn) and
 432                                  (p^.symtable=aktprocsym^.definition^.localst) then
 433                                 pwithsymtable(withsymtable)^.direct_with:=true;
 434                               {symtab^.withnode:=p; not yet allocated !! }
 435                               pwithsymtable(withsymtable)^.withrefnode:=p;
 436                            withsymtable^.defowner:=precorddef(p^.resulttype);
 437                            symtablestack:=withsymtable;
 438                         end;
 439             end;
 440             if token=_COMMA then
 441              begin
 442                consume(_COMMA);
 443                right:=_with_statement{$ifndef tp}(){$endif};
 444              end
 445             else
 446              begin
 447                consume(_DO);
 448                if token<>_SEMICOLON then
 449                 right:=statement
 450                else
 451                 right:=nil;
 452              end;
 453             for i:=1 to levelcount do
 454              symtablestack:=symtablestack^.next;
 455             _with_statement:=genwithnode(pwithsymtable(withsymtable),p,right,levelcount);
 456           end
 457          else
 458           begin
 459             Message(parser_e_false_with_expr);
 460             { try to recover from error }
 461             if token=_COMMA then
 462              begin
 463                consume(_COMMA);
 464 {$ifdef tp}
 465                hp:=_with_statement;
 466 {$else}
 467                _with_statement();
 468 {$endif}
 469              end
 470             else
 471              begin
 472                consume(_DO);
 473                { ignore all }
 474                if token<>_SEMICOLON then
 475                 statement;
 476              end;
 477             _with_statement:=nil;
 478           end;
 479       end;
 480
 481
 482     function with_statement : ptree;
 483       begin
 484          consume(_WITH);
 485          with_statement:=_with_statement;
 486       end;
 487
 488
 489     function raise_statement : ptree;
 490
 491       var
 492          p,pobj,paddr,pframe : ptree;
 493
 494       begin
 495          pobj:=nil;
 496          paddr:=nil;
 497          pframe:=nil;
 498          consume(_RAISE);
 499          if not(token in [_SEMICOLON,_END]) then
 500            begin
 501               { object }
 502               pobj:=comp_expr(true);
 503               if try_to_consume(_AT) then
 504                 begin
 505                    paddr:=comp_expr(true);
 506                    if try_to_consume(_COMMA) then
 507                      pframe:=comp_expr(true);
 508                 end;
 509            end
 510          else
 511            begin
 512               if (block_type<>bt_except) then
 513                 Message(parser_e_no_reraise_possible);
 514            end;
 515          p:=genraisenode(pobj,paddr,pframe);
 516          raise_statement:=p;
 517       end;
 518
 519
 520     function try_statement : ptree;
 521
 522       var
 523          p_try_block,p_finally_block,first,last,
 524          p_default,p_specific,hp : ptree;
 525          ot : pobjectdef;
 526          sym : pvarsym;
 527          old_block_type : tblock_type;
 528          exceptsymtable : psymtable;
 529          objname : stringid;
 530
 531       begin
 532          procinfo^.flags:=procinfo^.flags or
 533            pi_uses_exceptions;
 534
 535          p_default:=nil;
 536          p_specific:=nil;
 537
 538          { read statements to try }
 539          consume(_TRY);
 540          first:=nil;
 541          inc(statement_level);
 542
 543          while (token<>_FINALLY) and (token<>_EXCEPT) do
 544            begin
 545               if first=nil then
 546                 begin
 547                    last:=gennode(statementn,nil,statement);
 548                    first:=last;
 549                 end
 550               else
 551                 begin
 552                    last^.left:=gennode(statementn,nil,statement);
 553                    last:=last^.left;
 554                 end;
 555               if not try_to_consume(_SEMICOLON) then
 556                 break;
 557               emptystats;
 558            end;
 559          p_try_block:=gensinglenode(blockn,first);
 560
 561          if try_to_consume(_FINALLY) then
 562            begin
 563               p_finally_block:=statements_til_end;
 564               try_statement:=gennode(tryfinallyn,p_try_block,p_finally_block);
 565               dec(statement_level);
 566
 567            end
 568          else
 569            begin
 570               consume(_EXCEPT);
 571               old_block_type:=block_type;
 572               block_type:=bt_except;
 573               ot:=pobjectdef(generrordef);
 574               p_specific:=nil;
 575               if token=_ON then
 576                 { catch specific exceptions }
 577                 begin
 578                    repeat
 579                      consume(_ON);
 580                      if token=_ID then
 581                        begin
 582                           objname:=pattern;
 583                           getsym(objname,false);
 584                           consume(_ID);
 585                           { is a explicit name for the exception given ? }
 586                           if try_to_consume(_COLON) then
 587                             begin
 588                                getsym(pattern,true);
 589                                consume(_ID);
 590                                if srsym^.typ=unitsym then
 591                                  begin
 592                                     consume(_POINT);
 593                                     getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
 594                                     consume(_ID);
 595                                  end;
 596                                if (srsym^.typ=typesym) and
 597                                  (ptypesym(srsym)^.restype.def^.deftype=objectdef) and
 598                                  pobjectdef(ptypesym(srsym)^.restype.def)^.is_class then
 599                                  begin
 600                                     ot:=pobjectdef(ptypesym(srsym)^.restype.def);
 601                                     sym:=new(pvarsym,initdef(objname,ot));
 602                                  end
 603                                else
 604                                  begin
 605                                     sym:=new(pvarsym,initdef(objname,new(perrordef,init)));
 606                                     if (srsym^.typ=typesym) then
 607                                       Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.typename)
 608                                     else
 609                                       Message1(type_e_class_type_expected,ot^.typename);
 610                                  end;
 611                                exceptsymtable:=new(psymtable,init(stt_exceptsymtable));
 612                                exceptsymtable^.insert(sym);
 613                                { insert the exception symtable stack }
 614                                exceptsymtable^.next:=symtablestack;
 615                                symtablestack:=exceptsymtable;
 616                             end
 617                           else
 618                             begin
 619                                { check if type is valid, must be done here because
 620                                  with "e: Exception" the e is not necessary }
 621                                if srsym=nil then
 622                                 begin
 623                                   Message1(sym_e_id_not_found,objname);
 624                                   srsym:=generrorsym;
 625                                 end;
 626                                { only exception type }
 627                                if srsym^.typ=unitsym then
 628                                  begin
 629                                     consume(_POINT);
 630                                     getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
 631                                     consume(_ID);
 632                                  end;
 633                                if (srsym^.typ=typesym) and
 634                                  (ptypesym(srsym)^.restype.def^.deftype=objectdef) and
 635                                  pobjectdef(ptypesym(srsym)^.restype.def)^.is_class then
 636                                  ot:=pobjectdef(ptypesym(srsym)^.restype.def)
 637                                else
 638                                  begin
 639                                     ot:=pobjectdef(generrordef);
 640                                     if (srsym^.typ=typesym) then
 641                                       Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.typename)
 642                                     else
 643                                       Message1(type_e_class_type_expected,ot^.typename);
 644                                  end;
 645                                exceptsymtable:=nil;
 646                             end;
 647                        end
 648                      else
 649                        consume(_ID);
 650                      consume(_DO);
 651                      hp:=gennode(onn,nil,statement);
 652                      if ot^.deftype=errordef then
 653                        begin
 654                           disposetree(hp);
 655                           hp:=genzeronode(errorn);
 656                        end;
 657                      if p_specific=nil then
 658                        begin
 659                           last:=hp;
 660                           p_specific:=last;
 661                        end
 662                      else
 663                        begin
 664                           last^.left:=hp;
 665                           last:=last^.left;
 666                        end;
 667                      { set the informations }
 668                      if last^.treetype = onn then
 669                        begin
 670                          last^.excepttype:=ot;
 671                          last^.exceptsymtable:=exceptsymtable;
 672                          last^.disposetyp:=dt_onn;
 673                        end;
 674                      { remove exception symtable }
 675                      if assigned(exceptsymtable) then
 676                        begin
 677                          dellexlevel;
 678                          if last^.treetype <> onn then
 679                            dispose(exceptsymtable,done);
 680                        end;
 681                      if not try_to_consume(_SEMICOLON) then
 682                         break;
 683                      emptystats;
 684                    until (token=_END) or(token=_ELSE);
 685                    if token=_ELSE then
 686                      { catch the other exceptions }
 687                      begin
 688                         consume(_ELSE);
 689                         p_default:=statements_til_end;
 690                      end
 691                    else
 692                      consume(_END);
 693                 end
 694               else
 695                 { catch all exceptions }
 696                 begin
 697                    p_default:=statements_til_end;
 698                 end;
 699               dec(statement_level);
 700
 701               block_type:=old_block_type;
 702               try_statement:=genloopnode(tryexceptn,p_try_block,p_specific,p_default,false);
 703            end;
 704       end;
 705
 706
 707     function exit_statement : ptree;
 708
 709       var
 710          p : ptree;
 711
 712       begin
 713          consume(_EXIT);
 714          if try_to_consume(_LKLAMMER) then
 715            begin
 716               p:=comp_expr(true);
 717               consume(_RKLAMMER);
 718               if (block_type=bt_except) then
 719                 Message(parser_e_exit_with_argument_not__possible);
 720               if procinfo^.returntype.def=pdef(voiddef) then
 721                 Message(parser_e_void_function);
 722            end
 723          else
 724            p:=nil;
 725          p:=gensinglenode(exitn,p);
 726          // p^.resulttype:=procinfo^.returntype.def;
 727          p^.resulttype:=voiddef;
 728          exit_statement:=p;
 729       end;
 730
 731
 732     function _asm_statement : ptree;
 733       var
 734         asmstat : ptree;
 735         Marker : Pai;
 736       begin
 737          Inside_asm_statement:=true;
 738          case aktasmmode of
 739            asmmode_none : ; { just be there to allow to a compile without
 740                               any assembler readers }
 741 {$ifdef i386}
 742   {$ifndef NoRA386Att}
 743            asmmode_i386_att:
 744              asmstat:=ra386att.assemble;
 745   {$endif NoRA386Att}
 746   {$ifndef NoRA386Int}
 747            asmmode_i386_intel:
 748              asmstat:=ra386int.assemble;
 749   {$endif NoRA386Int}
 750   {$ifndef NoRA386Dir}
 751            asmmode_i386_direct:
 752              begin
 753                if not target_asm.allowdirect then
 754                  Message(parser_f_direct_assembler_not_allowed);
 755                if (pocall_inline in aktprocsym^.definition^.proccalloptions) then
 756                  Begin
 757                     Message1(parser_w_not_supported_for_inline,'direct asm');
 758                     Message(parser_w_inlining_disabled);
 759 {$ifdef INCLUDEOK}
 760                     exclude(aktprocsym^.definition^.proccalloptions,pocall_inline);
 761 {$else}
 762                     aktprocsym^.definition^.proccalloptions:=aktprocsym^.definition^.proccalloptions-[pocall_inline];
 763 {$endif}
 764                  End;
 765                asmstat:=ra386dir.assemble;
 766              end;
 767   {$endif NoRA386Dir}
 768 {$endif}
 769 {$ifdef m68k}
 770   {$ifndef NoRA68kMot}
 771            asmmode_m68k_mot:
 772              asmstat:=ra68kmot.assemble;
 773   {$endif NoRA68kMot}
 774 {$endif}
 775          else
 776            Message(parser_f_assembler_reader_not_supported);
 777          end;
 778
 779          { Read first the _ASM statement }
 780          consume(_ASM);
 781
 782 {$ifndef newcg}
 783          { END is read }
 784          if try_to_consume(_LECKKLAMMER) then
 785            begin
 786               { it's possible to specify the modified registers }
 787               asmstat^.object_preserved:=true;
 788               if token<>_RECKKLAMMER then
 789                 repeat
 790                 { uppercase, because it's a CSTRING }
 791                   uppervar(pattern);
 792 {$ifdef i386}
 793                   if pattern='EAX' then
 794                     usedinproc:=usedinproc or ($80 shr byte(R_EAX))
 795                   else if pattern='EBX' then
 796                     usedinproc:=usedinproc or ($80 shr byte(R_EBX))
 797                   else if pattern='ECX' then
 798                     usedinproc:=usedinproc or ($80 shr byte(R_ECX))
 799                   else if pattern='EDX' then
 800                     usedinproc:=usedinproc or ($80 shr byte(R_EDX))
 801                   else if pattern='ESI' then
 802                     begin
 803                        usedinproc:=usedinproc or ($80 shr byte(R_ESI));
 804                        asmstat^.object_preserved:=false;
 805                     end
 806                   else if pattern='EDI' then
 807                     usedinproc:=usedinproc or ($80 shr byte(R_EDI))
 808 {$endif i386}
 809 {$ifdef m68k}
 810                   if pattern='D0' then
 811                     usedinproc:=usedinproc or ($800 shr word(R_D0))
 812                   else if pattern='D1' then
 813                     usedinproc:=usedinproc or ($800 shr word(R_D1))
 814                   else if pattern='D6' then
 815                     usedinproc:=usedinproc or ($800 shr word(R_D6))
 816                   else if pattern='A0' then
 817                     usedinproc:=usedinproc or ($800 shr word(R_A0))
 818                   else if pattern='A1' then
 819                     usedinproc:=usedinproc or ($800 shr word(R_A1))
 820 {$endif m68k}
 821                   else consume(_RECKKLAMMER);
 822                   consume(_CSTRING);
 823                   if not try_to_consume(_COMMA) then
 824                     break;
 825                 until false;
 826               consume(_RECKKLAMMER);
 827            end
 828          else usedinproc:=$ff;
 829 {$endif newcg}
 830
 831 { mark the start and the end of the assembler block for the optimizer }
 832
 833          If Assigned(AsmStat^.p_asm) Then
 834            Begin
 835              Marker := New(Pai_Marker, Init(AsmBlockStart));
 836              AsmStat^.p_asm^.Insert(Marker);
 837              Marker := New(Pai_Marker, Init(AsmBlockEnd));
 838              AsmStat^.p_asm^.Concat(Marker);
 839            End;
 840          Inside_asm_statement:=false;
 841
 842          _asm_statement:=asmstat;
 843       end;
 844
 845
 846         function new_dispose_statement : ptree;
 847         var
 848           p,p2 : ptree;
 849           ht : ttoken;
 850           again : boolean; { dummy for do_proc_call }
 851           destructorname : stringid;
 852           sym : psym;
 853           classh : pobjectdef;
 854           pd,pd2 : pdef;
 855           destructorpos,storepos : tfileposinfo;
 856           tt : ttreetyp;
 857         begin
 858           ht:=token;
 859           if try_to_consume(_NEW) then
 860             tt:=hnewn
 861           else
 862             begin
 863                 consume(_DISPOSE);
 864                 tt:=hdisposen;
 865             end;
 866           consume(_LKLAMMER);
 867
 868
 869           p:=comp_expr(true);
 870
 871           { calc return type }
 872           cleartempgen;
 873           do_firstpass(p);
 874           set_varstate(p,tt=hdisposen);
 875
 876   {var o:Pobject;
 877            begin
 878                new(o,init);     (*Also a valid new statement*)
 879            end;}
 880
 881           if try_to_consume(_COMMA) then
 882             begin
 883                    { extended syntax of new and dispose }
 884                    { function styled new is handled in factor }
 885                    { destructors have no parameters }
 886                    destructorname:=pattern;
 887                    destructorpos:=tokenpos;
 888                    consume(_ID);
 889
 890                    pd:=p^.resulttype;
 891                    if pd=nil then
 892                     pd:=generrordef;
 893                    pd2:=pd;
 894                    if (pd^.deftype<>pointerdef) then
 895                      begin
 896                         Message1(type_e_pointer_type_expected,pd^.typename);
 897                         p:=factor(false);
 898                         consume(_RKLAMMER);
 899                         new_dispose_statement:=genzeronode(errorn);
 900                         exit;
 901                      end;
 902                    { first parameter must be an object or class }
 903                    if ppointerdef(pd)^.pointertype.def^.deftype<>objectdef then
 904                      begin
 905                         Message(parser_e_pointer_to_class_expected);
 906                         new_dispose_statement:=factor(false);
 907                         consume_all_until(_RKLAMMER);
 908                         consume(_RKLAMMER);
 909                         exit;
 910                      end;
 911                    { check, if the first parameter is a pointer to a _class_ }
 912                    classh:=pobjectdef(ppointerdef(pd)^.pointertype.def);
 913                    if classh^.is_class then
 914                      begin
 915                         Message(parser_e_no_new_or_dispose_for_classes);
 916                         new_dispose_statement:=factor(false);
 917                         consume_all_until(_RKLAMMER);
 918                         consume(_RKLAMMER);
 919                         exit;
 920                      end;
 921                    { search cons-/destructor, also in parent classes }
 922                    storepos:=tokenpos;
 923                    tokenpos:=destructorpos;
 924                    sym:=search_class_member(classh,destructorname);
 925                    tokenpos:=storepos;
 926
 927                    { the second parameter of new/dispose must be a call }
 928                    { to a cons-/destructor                              }
 929                    if (not assigned(sym)) or (sym^.typ<>procsym) then
 930                          begin
 931                             if tt=hnewn then
 932                              Message(parser_e_expr_have_to_be_constructor_call)
 933                             else
 934                              Message(parser_e_expr_have_to_be_destructor_call);
 935                             new_dispose_statement:=genzeronode(errorn);
 936                          end
 937                    else
 938                          begin
 939                            p2:=gensinglenode(tt,p);
 940                            if ht=_NEW then
 941                              begin
 942                                { Constructors can take parameters.}
 943                                p2^.resulttype:=ppointerdef(pd)^.pointertype.def;
 944                                do_member_read(false,sym,p2,pd,again);
 945                              end
 946                            else
 947                              begin
 948                                if (m_tp in aktmodeswitches) then
 949                                  begin
 950                                    { Constructors can take parameters.}
 951                                    p2^.resulttype:=ppointerdef(pd)^.pointertype.def;
 952                                    do_member_read(false,sym,p2,pd,again);
 953                                  end
 954                                else
 955                                  begin
 956                                    p2:=genmethodcallnode(pprocsym(sym),srsymtable,p2);
 957                                    { support dispose(p,done()); }
 958                                    if try_to_consume(_LKLAMMER) then
 959                                      begin
 960                                        if not try_to_consume(_RKLAMMER) then
 961                                          begin
 962                                            Message(parser_e_no_paras_for_destructor);
 963                                            consume_all_until(_RKLAMMER);
 964                                            consume(_RKLAMMER);
 965                                          end;
 966                                      end;
 967                                  end;
 968                              end;
 969
 970                            { we need the real called method }
 971                            cleartempgen;
 972                            do_firstpass(p2);
 973
 974                            if not codegenerror then
 975                             begin
 976                               if (ht=_NEW) and (p2^.procdefinition^.proctypeoption<>potype_constructor) then
 977                                 Message(parser_e_expr_have_to_be_constructor_call);
 978                               if (ht=_DISPOSE) and (p2^.procdefinition^.proctypeoption<>potype_destructor) then
 979                                 Message(parser_e_expr_have_to_be_destructor_call);
 980
 981                               if ht=_NEW then
 982                                begin
 983                                  p2:=gennode(assignn,getcopy(p),gensinglenode(newn,p2));
 984                                  p2^.right^.resulttype:=pd2;
 985                                end;
 986                             end;
 987                            new_dispose_statement:=p2;
 988                          end;
 989             end
 990           else
 991             begin
 992                if p^.resulttype=nil then
 993                 p^.resulttype:=generrordef;
 994                if (p^.resulttype^.deftype<>pointerdef) then
 995                  Begin
 996                     Message1(type_e_pointer_type_expected,p^.resulttype^.typename);
 997                     new_dispose_statement:=genzeronode(errorn);
 998                  end
 999                else
1000                  begin
1001                     if (ppointerdef(p^.resulttype)^.pointertype.def^.deftype=objectdef) and
1002                        (oo_has_vmt in pobjectdef(ppointerdef(p^.resulttype)^.pointertype.def)^.objectoptions) then
1003                       Message(parser_w_use_extended_syntax_for_objects);
1004                     if (ppointerdef(p^.resulttype)^.pointertype.def^.deftype=orddef) and
1005                        (porddef(ppointerdef(p^.resulttype)^.pointertype.def)^.typ=uvoid) then
1006                       if (m_tp in aktmodeswitches) or
1007                          (m_delphi in aktmodeswitches) then
1008                        Message(parser_w_no_new_dispose_on_void_pointers)
1009                       else
1010                        Message(parser_e_no_new_dispose_on_void_pointers);
1011
1012                      case ht of
1013                         _NEW : new_dispose_statement:=gensinglenode(simplenewn,p);
1014                         _DISPOSE : new_dispose_statement:=gensinglenode(simpledisposen,p);
1015                      end;
1016                  end;
1017             end;
1018           consume(_RKLAMMER);
1019       end;
1020
1021
1022     function statement_block(starttoken : ttoken) : ptree;
1023
1024       var
1025          first,last : ptree;
1026          filepos : tfileposinfo;
1027
1028       begin
1029          first:=nil;
1030          filepos:=tokenpos;
1031          consume(starttoken);
1032          inc(statement_level);
1033
1034          while not(token in [_END,_FINALIZATION]) do
1035            begin
1036               if first=nil then
1037                 begin
1038                    last:=gennode(statementn,nil,statement);
1039                    first:=last;
1040                 end
1041               else
1042                 begin
1043                    last^.left:=gennode(statementn,nil,statement);
1044                    last:=last^.left;
1045                 end;
1046               if (token in [_END,_FINALIZATION]) then
1047                 break
1048               else
1049                 begin
1050                    { if no semicolon, then error and go on }
1051                    if token<>_SEMICOLON then
1052                      begin
1053                         consume(_SEMICOLON);
1054                         consume_all_until(_SEMICOLON);
1055                      end;
1056                    consume(_SEMICOLON);
1057                 end;
1058               emptystats;
1059            end;
1060
1061          { don't consume the finalization token, it is consumed when
1062            reading the finalization block, but allow it only after
1063            an initalization ! }
1064          if (starttoken<>_INITIALIZATION) or (token<>_FINALIZATION) then
1065            consume(_END);
1066
1067          dec(statement_level);
1068
1069          last:=gensinglenode(blockn,first);
1070          set_tree_filepos(last,filepos);
1071          statement_block:=last;
1072       end;
1073
1074
1075     function statement : ptree;
1076
1077       var
1078          p : ptree;
1079          code : ptree;
1080          labelnr : pasmlabel;
1081          filepos : tfileposinfo;
1082          sr : plabelsym;
1083
1084       label
1085          ready;
1086
1087       begin
1088          filepos:=tokenpos;
1089          case token of
1090             _GOTO : begin
1091                        if not(cs_support_goto in aktmoduleswitches)then
1092                         Message(sym_e_goto_and_label_not_supported);
1093                        consume(_GOTO);
1094                        if (token<>_INTCONST) and (token<>_ID) then
1095                          begin
1096                             Message(sym_e_label_not_found);
1097                             code:=genzeronode(errorn);
1098                          end
1099                        else
1100                          begin
1101                             getsym(pattern,true);
1102                             consume(token);
1103                             if srsym^.typ<>labelsym then
1104                               begin
1105                                  Message(sym_e_id_is_no_label_id);
1106                                  code:=genzeronode(errorn);
1107                               end
1108                             else
1109                               begin
1110                                 code:=genlabelnode(goton,plabelsym(srsym)^.lab);
1111                                 code^.labsym:=plabelsym(srsym);
1112                                 { set flag that this label is used }
1113                                 plabelsym(srsym)^.used:=true;
1114                               end;
1115                          end;
1116                     end;
1117             _BEGIN : code:=statement_block(_BEGIN);
1118             _IF    : code:=if_statement;
1119             _CASE  : code:=case_statement;
1120             _REPEAT : code:=repeat_statement;
1121             _WHILE : code:=while_statement;
1122             _FOR : code:=for_statement;
1123             _NEW,_DISPOSE : code:=new_dispose_statement;
1124
1125             _WITH : code:=with_statement;
1126             _TRY : code:=try_statement;
1127             _RAISE : code:=raise_statement;
1128             { semicolons,else until and end are ignored }
1129             _SEMICOLON,
1130             _ELSE,
1131             _UNTIL,
1132             _END:
1133               code:=genzeronode(niln);
1134             _FAIL : begin
1135                        { internalerror(100); }
1136                        if (aktprocsym^.definition^.proctypeoption<>potype_constructor) then
1137                         Message(parser_e_fail_only_in_constructor);
1138                        consume(_FAIL);
1139                        code:=genzeronode(failn);
1140                     end;
1141             _EXIT : code:=exit_statement;
1142             _ASM : begin
1143                       code:=_asm_statement;
1144                    end;
1145             _EOF : begin
1146                      Message(scan_f_end_of_file);
1147                    end;
1148          else
1149            begin
1150               if (token in [_INTCONST,_ID]) then
1151                 begin
1152                    getsym(pattern,true);
1153                    lastsymknown:=true;
1154                    lastsrsym:=srsym;
1155                    { it is NOT necessarily the owner
1156                      it can be a withsymtable !!! }
1157                    lastsrsymtable:=srsymtable;
1158                    if assigned(srsym) and (srsym^.typ=labelsym) then
1159                      begin
1160                         consume(token);
1161                         consume(_COLON);
1162                         { we must preserve srsym to set code later }
1163                         sr:=plabelsym(srsym);
1164                         if sr^.defined then
1165                           Message(sym_e_label_already_defined);
1166                         sr^.defined:=true;
1167
1168                         { statement modifies srsym }
1169                         labelnr:=sr^.lab;
1170                         lastsymknown:=false;
1171                         { the pointer to the following instruction }
1172                         { isn't a very clean way                   }
1173                         code:=gensinglenode(labeln,statement{$ifndef tp}(){$endif});
1174                         code^.labelnr:=labelnr;
1175                         sr^.code:=code;
1176                         { sorry, but there is a jump the easiest way }
1177                         goto ready;
1178                      end;
1179                 end;
1180               p:=expr;
1181               if not(p^.treetype in [calln,assignn,breakn,inlinen,
1182                 continuen]) then
1183                 Message(cg_e_illegal_expression);
1184               { specify that we don't use the value returned by the call }
1185               { Question : can this be also improtant
1186                 for inlinen ??
1187                 it is used for :
1188                  - dispose of temp stack space
1189                  - dispose on FPU stack }
1190               if p^.treetype=calln then
1191                 p^.return_value_used:=false;
1192               code:=p;
1193            end;
1194          end;
1195          ready:
1196          if assigned(code) then
1197           set_tree_filepos(code,filepos);
1198          statement:=code;
1199       end;
1200
1201     function block(islibrary : boolean) : ptree;
1202
1203       var
1204          funcretsym : pfuncretsym;
1205          storepos : tfileposinfo;
1206
1207       begin
1208          { do we have an assembler block without the po_assembler?
1209            we should allow this for Delphi compatibility (PFV) }
1210          if (token=_ASM) and (m_delphi in aktmodeswitches) then
1211            begin
1212              include(aktprocsym^.definition^.procoptions,po_assembler);
1213              block:=assembler_block;
1214              exit;
1215            end;
1216          if procinfo^.returntype.def<>pdef(voiddef) then
1217            begin
1218               { if the current is a function aktprocsym is non nil }
1219               { and there is a local symtable set }
1220               storepos:=tokenpos;
1221               tokenpos:=aktprocsym^.fileinfo;
1222               funcretsym:=new(pfuncretsym,init(aktprocsym^.name,procinfo));
1223               { insert in local symtable }
1224               symtablestack^.insert(funcretsym);
1225               tokenpos:=storepos;
1226               if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then
1227                 procinfo^.return_offset:=-funcretsym^.address;
1228               procinfo^.funcretsym:=funcretsym;
1229               { insert result also if support is on }
1230               if (m_result in aktmodeswitches) then
1231                begin
1232                  procinfo^.resultfuncretsym:=new(pfuncretsym,init('RESULT',procinfo));
1233                  symtablestack^.insert(procinfo^.resultfuncretsym);
1234                end;
1235            end;
1236          read_declarations(islibrary);
1237
1238          { temporary space is set, while the BEGIN of the procedure }
1239          if (symtablestack^.symtabletype=localsymtable) then
1240            procinfo^.firsttemp_offset := -symtablestack^.datasize
1241          else
1242            procinfo^.firsttemp_offset := 0;
1243
1244          { space for the return value }
1245          { !!!!!   this means that we can not set the return value
1246          in a subfunction !!!!! }
1247          { because we don't know yet where the address is }
1248          if procinfo^.returntype.def<>pdef(voiddef) then
1249            begin
1250               if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then
1251               { if (procinfo^.retdef^.deftype=orddef) or
1252                  (procinfo^.retdef^.deftype=pointerdef) or
1253                  (procinfo^.retdef^.deftype=enumdef) or
1254                  (procinfo^.retdef^.deftype=procvardef) or
1255                  (procinfo^.retdef^.deftype=floatdef) or
1256                  (
1257                    (procinfo^.retdef^.deftype=setdef) and
1258                    (psetdef(procinfo^.retdef)^.settype=smallset)
1259                  ) then  }
1260                 begin
1261                    { the space has been set in the local symtable }
1262                    procinfo^.return_offset:=-funcretsym^.address;
1263                    if ((procinfo^.flags and pi_operator)<>0) and
1264                      assigned(opsym) then
1265                      {opsym^.address:=procinfo^.para_offset; is wrong PM }
1266                      opsym^.address:=-procinfo^.return_offset;
1267                    { eax is modified by a function }
1268 {$ifndef newcg}
1269 {$ifdef i386}
1270                    usedinproc:=usedinproc or ($80 shr byte(R_EAX));
1271
1272                    if is_64bitint(procinfo^.returntype.def) then
1273                      usedinproc:=usedinproc or ($80 shr byte(R_EDX))
1274 {$endif}
1275 {$ifdef m68k}
1276                    usedinproc:=usedinproc or ($800 shr word(R_D0));
1277
1278                    if is_64bitint(procinfo^.retdef) then
1279                      usedinproc:=usedinproc or ($800 shr byte(R_D1))
1280 {$endif}
1281 {$endif newcg}
1282                 end;
1283            end;
1284
1285          {Unit initialization?.}
1286          if (lexlevel=unit_init_level) and (current_module^.is_unit)
1287             or islibrary then
1288            begin
1289              if (token=_END) then
1290                 begin
1291                    consume(_END);
1292                    { We need at least a node, else the entry/exit code is not
1293                      generated and thus no PASCALMAIN symbol which we need (PFV) }
1294                    if islibrary then
1295                     block:=genzeronode(nothingn)
1296                    else
1297                     block:=nil;
1298                 end
1299               else
1300                 begin
1301                    if token=_INITIALIZATION then
1302                      begin
1303                         current_module^.flags:=current_module^.flags or uf_init;
1304                         block:=statement_block(_INITIALIZATION);
1305                      end
1306                    else if (token=_FINALIZATION) then
1307                      begin
1308                         if (current_module^.flags and uf_finalize)<>0 then
1309                           block:=statement_block(_FINALIZATION)
1310                         else
1311                           begin
1312                           { can we allow no INITIALIZATION for DLL ??
1313                             I think it should work PM }
1314                              block:=nil;
1315                              exit;
1316                           end;
1317                      end
1318                    else
1319                      begin
1320                         current_module^.flags:=current_module^.flags or uf_init;
1321                         block:=statement_block(_BEGIN);
1322                      end;
1323                 end;
1324             end
1325          else
1326             block:=statement_block(_BEGIN);
1327       end;
1328
1329     function assembler_block : ptree;
1330
1331       begin
1332          read_declarations(false);
1333          { temporary space is set, while the BEGIN of the procedure }
1334          if symtablestack^.symtabletype=localsymtable then
1335            procinfo^.firsttemp_offset := -symtablestack^.datasize
1336          else
1337            procinfo^.firsttemp_offset := 0;
1338
1339          { assembler code does not allocate }
1340          { space for the return value       }
1341           if procinfo^.returntype.def<>pdef(voiddef) then
1342            begin
1343               if ret_in_acc(procinfo^.returntype.def) then
1344                 begin
1345                    { in assembler code the result should be directly in %eax
1346                    procinfo^.retoffset:=procinfo^.firsttemp-procinfo^.retdef^.size;
1347                    procinfo^.firsttemp:=procinfo^.retoffset;                 }
1348
1349 {$ifndef newcg}
1350 {$ifdef i386}
1351                    usedinproc:=usedinproc or ($80 shr byte(R_EAX))
1352 {$endif}
1353 {$ifdef m68k}
1354                    usedinproc:=usedinproc or ($800 shr word(R_D0))
1355 {$endif}
1356 {$endif newcg}
1357                 end
1358               {
1359               else if not is_fpu(procinfo^.retdef) then
1360                should we allow assembler functions of big elements ?
1361                 YES (FK)!!
1362                Message(parser_e_asm_incomp_with_function_return);
1363               }
1364             end;
1365            { set the framepointer to esp for assembler functions }
1366            { but only if the are no local variables           }
1367            { added no parameter also (PM)                       }
1368            { disable for methods, because self pointer is expected }
1369            { at -8(%ebp) (JM)                                      }
1370            { why if se use %esp then self is still at the correct address PM }
1371            if {not(assigned(procinfo^._class)) and}
1372               (po_assembler in aktprocsym^.definition^.procoptions) and
1373               (aktprocsym^.definition^.localst^.datasize=0) and
1374               (aktprocsym^.definition^.parast^.datasize=0) and
1375               not(ret_in_param(aktprocsym^.definition^.rettype.def)) then
1376              begin
1377                procinfo^.framepointer:=stack_pointer;
1378                { set the right value for parameters }
1379                dec(aktprocsym^.definition^.parast^.address_fixup,target_os.size_of_pointer);
1380                dec(procinfo^.para_offset,target_os.size_of_pointer);
1381              end;
1382           { force the asm statement }
1383             if token<>_ASM then
1384              consume(_ASM);
1385             procinfo^.Flags := procinfo^.Flags Or pi_is_assembler;
1386             assembler_block:=_asm_statement;
1387           { becuase the END is already read we need to get the
1388             last_endtoken_filepos here (PFV) }
1389             last_endtoken_filepos:=tokenpos;
1390           end;
1391
1392 end.
1393 {
1394   $Log$
1395   Revision 1.1  2002/02/19 08:23:34  sasu
1396   Initial revision
1397
1398   Revision 1.1.2.4  2000/11/27 16:05:06  jonas
1399     * fix for web bug 1251 (example 1)
1400
1401   Revision 1.1.2.3  2000/11/22 22:42:42  peter
1402     * fixed crash with exception without sysutils
1403
1404   Revision 1.1.2.2  2000/09/26 08:49:03  pierre
1405    * avoid memory leak with raisen
1406
1407   Revision 1.1.2.1  2000/08/11 15:15:43  florian
1408     * fixed bug 1096 (problem with exit in $X- mode)
1409
1410   Revision 1.1  2000/07/13 06:29:54  michael
1411   + Initial import
1412
1413   Revision 1.131  2000/06/30 22:15:39  peter
1414     * fixed internalerror 2002 when case expr is not correct, by creating
1415       a temp correct case expression
1416
1417   Revision 1.130  2000/05/04 12:59:10  pierre
1418    * bug found by Kovacs Attila Zoltan corrected
1419
1420   Revision 1.129  2000/04/29 12:50:14  peter
1421     * support asm block without assembler directive for -Sd
1422
1423   Revision 1.128  2000/04/24 11:11:50  peter
1424     * backtraces for exceptions are now only generated from the place of the
1425       exception
1426     * frame is also pushed for exceptions
1427     * raise statement enhanced with [,<frame>]
1428
1429   Revision 1.127  2000/03/19 14:17:05  florian
1430     * crash when using exception classes without sysutils unit fixed
1431
1432   Revision 1.126  2000/03/19 11:16:44  peter
1433     * check for unknown id in on exception
1434
1435   Revision 1.125  2000/03/16 15:12:06  pierre
1436    assembler method code does not need ebp framepointer
1437
1438   Revision 1.124  2000/03/14 16:37:25  pierre
1439    * destructor can have args in TP mode only (bug825 and 839)
1440
1441   Revision 1.123  2000/02/29 23:59:47  pierre
1442    Use $GOTO ON
1443
1444   Revision 1.122  2000/02/09 13:22:59  peter
1445     * log truncated
1446
1447   Revision 1.121  2000/01/23 16:33:49  peter
1448     * fixed destructor parsing with preprocessor things
1449     * support dipsoe(p,done())
1450     * fixed constructor message with dispose(p,<nonexist>)
1451
1452   Revision 1.120  2000/01/16 22:17:12  peter
1453     * renamed call_offset to para_offset
1454
1455   Revision 1.119  2000/01/12 10:30:50  peter
1456     * fixed library with only end.
1457
1458   Revision 1.118  2000/01/07 01:14:31  peter
1459     * updated copyright to 2000
1460
1461   Revision 1.117  1999/12/22 01:01:52  peter
1462     - removed freelabel()
1463     * added undefined label detection in internal assembler, this prevents
1464       a lot of ld crashes and wrong .o files
1465     * .o files aren't written anymore if errors have occured
1466     * inlining of assembler labels is now correct
1467
1468   Revision 1.116  1999/12/14 09:58:42  florian
1469     + compiler checks now if a goto leaves an exception block
1470
1471   Revision 1.115  1999/12/01 22:43:17  peter
1472     * fixed sigsegv with casedef=nil
1473
1474   Revision 1.114  1999/12/01 12:42:32  peter
1475     * fixed bug 698
1476     * removed some notes about unused vars
1477
1478   Revision 1.113  1999/11/30 10:40:45  peter
1479     + ttype, tsymlist
1480
1481   Revision 1.112  1999/11/20 01:19:10  pierre
1482     * DLL index used for win32 target with DEF file
1483     + DLL initialization/finalization support
1484
1485   Revision 1.111  1999/11/18 15:34:48  pierre
1486     * Notes/Hints for local syms changed to
1487       Set_varstate function
1488
1489   Revision 1.110  1999/11/17 17:05:02  pierre
1490    * Notes/hints changes
1491
1492   Revision 1.109  1999/11/15 22:00:48  peter
1493     * labels used but not defined give error instead of warning, the warning
1494       is now only with declared but not defined and not used.
1495
1496   Revision 1.108  1999/11/10 00:24:02  pierre
1497    * more browser details
1498
1499   Revision 1.107  1999/11/09 13:02:46  peter
1500     * fixed 'raise end;'
1501
1502   Revision 1.106  1999/11/06 14:34:23  peter
1503     * truncated log to 20 revs
1504
1505   Revision 1.105  1999/10/22 10:39:35  peter
1506     * split type reading from pdecl to ptype unit
1507     * parameter_dec routine is now used for procedure and procvars
1508
1509   Revision 1.104  1999/10/14 14:57:54  florian
1510     - removed the hcodegen use in the new cg, use cgbase instead
1511
1512   Revision 1.103  1999/09/27 23:44:56  peter
1513     * procinfo is now a pointer
1514     * support for result setting in sub procedure
1515
1516   Revision 1.102  1999/09/16 23:05:54  florian
1517     * m68k compiler is again compilable (only gas writer, no assembler reader)
1518
1519 }