PageRenderTime 37ms CodeModel.GetById 19ms app.highlight 10ms RepoModel.GetById 0ms app.codeStats 1ms

/compiler/ptype.pas

https://github.com/slibre/freepascal
Pascal | 1805 lines | 1466 code | 84 blank | 255 comment | 195 complexity | 8429cbce16bababc1f1d8aceedbfeb21 MD5 | raw file
Possible License(s): LGPL-2.0, LGPL-2.1, LGPL-3.0

Large files files are truncated, but you can click here to view the full file

   1{
   2    Copyright (c) 1998-2002 by Florian Klaempfl
   3
   4    Does parsing types for Free Pascal
   5
   6    This program is free software; you can redistribute it and/or modify
   7    it under the terms of the GNU General Public License as published by
   8    the Free Software Foundation; either version 2 of the License, or
   9    (at your option) any later version.
  10
  11    This program is distributed in the hope that it will be useful,
  12    but WITHOUT ANY WARRANTY; without even the implied warranty of
  13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14    GNU General Public License for more details.
  15
  16    You should have received a copy of the GNU General Public License
  17    along with this program; if not, write to the Free Software
  18    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19
  20 ****************************************************************************
  21}
  22unit ptype;
  23
  24{$i fpcdefs.inc}
  25
  26interface
  27
  28    uses
  29       globtype,cclasses,
  30       symtype,symdef,symbase;
  31
  32    type
  33      TSingleTypeOption=(
  34        stoIsForwardDef,          { foward declaration         }
  35        stoAllowTypeDef,          { allow type definitions     }
  36        stoAllowSpecialization,   { allow type specialization  }
  37        stoParseClassParent       { parse of parent class type }
  38      );
  39      TSingleTypeOptions=set of TSingleTypeOption;
  40
  41    procedure resolve_forward_types;
  42
  43    { reads a string, file type or a type identifier }
  44    procedure single_type(var def:tdef;options:TSingleTypeOptions);
  45
  46    { reads any type declaration, where the resulting type will get name as type identifier }
  47    procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean;hadtypetoken:boolean);
  48
  49    { reads any type declaration }
  50    procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
  51
  52    { generate persistent type information like VMT, RTTI and inittables }
  53    procedure write_persistent_type_info(st:tsymtable;is_global:boolean);
  54
  55    { add a definition for a method to a record/objectdef that will contain
  56      all code for initialising typed constants (only for targets in
  57      systems.systems_typed_constants_node_init) }
  58    procedure add_typedconst_init_routine(def: tabstractrecorddef);
  59
  60    { parse hint directives (platform, deprecated, ...) for a procdef }
  61    procedure maybe_parse_hint_directives(pd:tprocdef);
  62
  63implementation
  64
  65    uses
  66       { common }
  67       cutils,
  68       { global }
  69       globals,tokens,verbose,constexp,
  70       systems,
  71       { target }
  72       paramgr,procinfo,
  73       { symtable }
  74       symconst,symsym,symtable,symcreat,
  75       defutil,defcmp,
  76{$ifdef jvm}
  77       jvmdef,
  78{$endif}
  79       { modules }
  80       fmodule,
  81       { pass 1 }
  82       node,ncgrtti,nobj,
  83       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
  84       { parser }
  85       scanner,
  86       pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil
  87{$ifdef jvm}
  88       ,pjvm
  89{$endif}
  90       ;
  91
  92
  93    procedure maybe_parse_hint_directives(pd:tprocdef);
  94      var
  95        dummysymoptions : tsymoptions;
  96        deprecatedmsg : pshortstring;
  97      begin
  98        dummysymoptions:=[];
  99        deprecatedmsg:=nil;
 100        while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do
 101          Consume(_SEMICOLON);
 102        if assigned(pd) then
 103          begin
 104            pd.symoptions:=pd.symoptions+dummysymoptions;
 105            pd.deprecatedmsg:=deprecatedmsg;
 106          end
 107        else
 108          stringdispose(deprecatedmsg);
 109      end;
 110
 111
 112    procedure resolve_forward_types;
 113      var
 114        i: longint;
 115        hpd,
 116        def : tdef;
 117        srsym  : tsym;
 118        srsymtable : TSymtable;
 119        hs : string;
 120      begin
 121        for i:=0 to current_module.checkforwarddefs.Count-1 do
 122          begin
 123            def:=tdef(current_module.checkforwarddefs[i]);
 124            case def.typ of
 125              pointerdef,
 126              classrefdef :
 127                begin
 128                  { classrefdef inherits from pointerdef }
 129                  hpd:=tabstractpointerdef(def).pointeddef;
 130                  { still a forward def ? }
 131                  if hpd.typ=forwarddef then
 132                   begin
 133                     { try to resolve the forward }
 134                     if not assigned(tforwarddef(hpd).tosymname) then
 135                       internalerror(200211201);
 136                     hs:=tforwarddef(hpd).tosymname^;
 137                     searchsym(upper(hs),srsym,srsymtable);
 138                     { we don't need the forwarddef anymore, dispose it }
 139                     hpd.free;
 140                     tabstractpointerdef(def).pointeddef:=nil; { if error occurs }
 141                     { was a type sym found ? }
 142                     if assigned(srsym) and
 143                        (srsym.typ=typesym) then
 144                      begin
 145                        tabstractpointerdef(def).pointeddef:=ttypesym(srsym).typedef;
 146                        { avoid wrong unused warnings web bug 801 PM }
 147                        inc(ttypesym(srsym).refs);
 148                        { we need a class type for classrefdef }
 149                        if (def.typ=classrefdef) and
 150                           not(is_class(ttypesym(srsym).typedef)) and
 151                           not(is_objcclass(ttypesym(srsym).typedef)) and
 152                           not(is_javaclass(ttypesym(srsym).typedef)) then
 153                          MessagePos1(def.typesym.fileinfo,type_e_class_type_expected,ttypesym(srsym).typedef.typename);
 154                        { this could also be a generic dummy that was not
 155                          overridden with a specific type }
 156                        if (sp_generic_dummy in srsym.symoptions) and
 157                            (
 158                              (ttypesym(srsym).typedef.typ=undefineddef) or
 159                              (
 160                                { or an unspecialized generic symbol, which is
 161                                  the case for generics defined in non-Delphi
 162                                  modes }
 163                                (df_generic in ttypesym(srsym).typedef.defoptions) and
 164                                not parse_generic
 165                              )
 166                            ) then
 167                          MessagePos(def.typesym.fileinfo,parser_e_no_generics_as_types);
 168                      end
 169                     else
 170                      begin
 171                        Message1(sym_e_forward_type_not_resolved,hs);
 172                        { try to recover }
 173                        tabstractpointerdef(def).pointeddef:=generrordef;
 174                      end;
 175                   end;
 176                end;
 177              objectdef :
 178                begin
 179                  { give an error as the implementation may follow in an
 180                    other type block which is allowed by FPC modes }
 181                  if not(m_fpc in current_settings.modeswitches) and
 182                     (oo_is_forward in tobjectdef(def).objectoptions) then
 183                    MessagePos1(def.typesym.fileinfo,type_e_type_is_not_completly_defined,def.typename);
 184                 end;
 185              else
 186                internalerror(200811071);
 187            end;
 188          end;
 189        current_module.checkforwarddefs.clear;
 190      end;
 191
 192
 193    procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean;out srsym:tsym;out srsymtable:tsymtable); forward;
 194
 195
 196    { def is the outermost type in which other types have to be searched
 197
 198      isforward indicates whether the current definition can be a forward definition
 199
 200      if assigned, currentstructstack is a list of tabstractrecorddefs that, from
 201      last to first, are child types of def that are not yet visible via the
 202      normal symtable searching routines because they are types that are currently
 203      being parsed (so using id_type on them after pushing def on the
 204      symtablestack would result in errors because they'd come back as errordef)
 205    }
 206    procedure parse_nested_types(var def: tdef; isforwarddef: boolean; currentstructstack: tfpobjectlist);
 207      var
 208        t2: tdef;
 209        structstackindex: longint;
 210        srsym: tsym;
 211        srsymtable: tsymtable;
 212        oldsymtablestack: TSymtablestack;
 213      begin
 214        if assigned(currentstructstack) then
 215          structstackindex:=currentstructstack.count-1
 216        else
 217          structstackindex:=-1;
 218        { handle types inside classes, e.g. TNode.TLongint }
 219        while (token=_POINT) do
 220          begin
 221             if is_class_or_object(def) or is_record(def) or is_java_class_or_interface(def) then
 222               begin
 223                 if (def.typ=objectdef) then
 224                   def:=find_real_class_definition(tobjectdef(def),false);
 225                 consume(_POINT);
 226                 if (structstackindex>=0) and
 227                    (tabstractrecorddef(currentstructstack[structstackindex]).objname^=pattern) then
 228                   begin
 229                     def:=tdef(currentstructstack[structstackindex]);
 230                     dec(structstackindex);
 231                     consume(_ID);
 232                   end
 233                 else
 234                   begin
 235                     structstackindex:=-1;
 236                     oldsymtablestack:=symtablestack;
 237                     symtablestack:=TSymtablestack.create;
 238                     symtablestack.push(tabstractrecorddef(def).symtable);
 239                     t2:=generrordef;
 240                     id_type(t2,isforwarddef,false,false,srsym,srsymtable);
 241                     symtablestack.pop(tabstractrecorddef(def).symtable);
 242                     symtablestack.free;
 243                     symtablestack:=oldsymtablestack;
 244                     def:=t2;
 245                   end;
 246               end
 247             else
 248               break;
 249          end;
 250      end;
 251
 252
 253    function try_parse_structdef_nested_type(out def: tdef; basedef: tabstractrecorddef; isfowarddef: boolean): boolean;
 254      var
 255        structdef : tdef;
 256        structdefstack : tfpobjectlist;
 257      begin
 258         def:=nil;
 259         { use of current parsed object:
 260           classes, objects, records can be used also in themself }
 261         structdef:=basedef;
 262         structdefstack:=nil;
 263         while assigned(structdef) and (structdef.typ in [objectdef,recorddef]) do
 264           begin
 265             if (tabstractrecorddef(structdef).objname^=pattern) then
 266               begin
 267                 consume(_ID);
 268                 def:=structdef;
 269                 { we found the top-most match, now check how far down we can
 270                   follow }
 271                 structdefstack:=tfpobjectlist.create(false);
 272                 structdef:=basedef;
 273                 while (structdef<>def) do
 274                   begin
 275                     structdefstack.add(structdef);
 276                     structdef:=tabstractrecorddef(structdef.owner.defowner);
 277                   end;
 278                 parse_nested_types(def,isfowarddef,structdefstack);
 279                 structdefstack.free;
 280                 result:=true;
 281                 exit;
 282               end;
 283             structdef:=tdef(tabstractrecorddef(structdef).owner.defowner);
 284           end;
 285         result:=false;
 286      end;
 287
 288    procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean;out srsym:tsym;out srsymtable:tsymtable);
 289    { reads a type definition }
 290    { to a appropriating tdef, s gets the name of   }
 291    { the type to allow name mangling          }
 292      var
 293        is_unit_specific : boolean;
 294        pos : tfileposinfo;
 295        s,sorg : TIDString;
 296        t : ttoken;
 297      begin
 298         srsym:=nil;
 299         srsymtable:=nil;
 300         s:=pattern;
 301         sorg:=orgpattern;
 302         pos:=current_tokenpos;
 303         { use of current parsed object:
 304           classes, objects, records can be used also in themself }
 305         if checkcurrentrecdef and
 306            try_parse_structdef_nested_type(def,current_structdef,isforwarddef) then
 307           exit;
 308         { Use the special searchsym_type that search only types }
 309         searchsym_type(s,srsym,srsymtable);
 310         { handle unit specification like System.Writeln }
 311         is_unit_specific:=try_consume_unitsym(srsym,srsymtable,t,true);
 312         consume(t);
 313         { Types are first defined with an error def before assigning
 314           the real type so check if it's an errordef. if so then
 315           give an error. Only check for typesyms in the current symbol
 316           table as forwarddef are not resolved directly }
 317         if assigned(srsym) and
 318            (srsym.typ=typesym) and
 319            ((ttypesym(srsym).typedef.typ=errordef) or
 320            (not allowgenericsyms and
 321            (ttypesym(srsym).typedef.typ=undefineddef) and
 322            not (sp_generic_para in srsym.symoptions))) then
 323          begin
 324            Message1(type_e_type_is_not_completly_defined,ttypesym(srsym).realname);
 325            def:=generrordef;
 326            exit;
 327          end;
 328         { are we parsing a possible forward def ? }
 329         if isforwarddef and
 330            not(is_unit_specific) then
 331           begin
 332             def:=tforwarddef.create(sorg,pos);
 333             exit;
 334           end;
 335         { unknown sym ? }
 336         if not assigned(srsym) then
 337          begin
 338            Message1(sym_e_id_not_found,sorg);
 339            def:=generrordef;
 340            exit;
 341          end;
 342         { type sym ? }
 343         if (srsym.typ<>typesym) then
 344          begin
 345            Message(type_e_type_id_expected);
 346            def:=generrordef;
 347            exit;
 348          end;
 349         { Give an error when referring to an errordef }
 350         if (ttypesym(srsym).typedef.typ=errordef) then
 351          begin
 352            Message(sym_e_error_in_type_def);
 353            def:=generrordef;
 354            exit;
 355          end;
 356         { In non-Delphi modes the class/record name of a generic might be used
 357           in the declaration of sub types without type parameters; in that case
 358           we need to check by name as the link from the dummy symbol to the
 359           current type is not yet established }
 360         if (sp_generic_dummy in srsym.symoptions) and
 361             assigned(current_structdef) and
 362             (df_generic in current_structdef.defoptions) and
 363             (ttypesym(srsym).typedef.typ=undefineddef) and
 364             not (m_delphi in current_settings.modeswitches) then
 365           begin
 366             def:=get_generic_in_hierarchy_by_name(srsym,current_structdef);
 367             if assigned(def) then
 368               exit;
 369           end;
 370        def:=ttypesym(srsym).typedef;
 371      end;
 372
 373
 374    procedure single_type(var def:tdef;options:TSingleTypeOptions);
 375       var
 376         t2 : tdef;
 377         dospecialize,
 378         again : boolean;
 379         srsym : tsym;
 380         srsymtable : tsymtable;
 381       begin
 382         dospecialize:=false;
 383         repeat
 384           again:=false;
 385             case token of
 386               _STRING:
 387                 string_dec(def,stoAllowTypeDef in options);
 388
 389               _FILE:
 390                 begin
 391                    consume(_FILE);
 392                    if (token=_OF) then
 393                      begin
 394                         if not(stoAllowTypeDef in options) then
 395                           Message(parser_e_no_local_para_def);
 396                         consume(_OF);
 397                         single_type(t2,[stoAllowTypeDef]);
 398                         if is_managed_type(t2) then
 399                           Message(parser_e_no_refcounted_typed_file);
 400                         def:=tfiledef.createtyped(t2);
 401                      end
 402                    else
 403                      def:=cfiletype;
 404                 end;
 405
 406               _ID:
 407                 begin
 408                   if try_to_consume(_SPECIALIZE) then
 409                     begin
 410                       if ([stoAllowSpecialization,stoAllowTypeDef] * options = []) then
 411                         begin
 412                           Message(parser_e_no_local_para_def);
 413
 414                           { try to recover }
 415                           while token<>_SEMICOLON do
 416                             consume(token);
 417                           def:=generrordef;
 418                         end
 419                       else
 420                         begin
 421                           dospecialize:=true;
 422                           again:=true;
 423                         end;
 424                     end
 425                   else
 426                     begin
 427                       id_type(def,stoIsForwardDef in options,true,true,srsym,srsymtable);
 428                       parse_nested_types(def,stoIsForwardDef in options,nil);
 429                     end;
 430                 end;
 431
 432               else
 433                 begin
 434                   message(type_e_type_id_expected);
 435                   def:=generrordef;
 436                 end;
 437            end;
 438        until not again;
 439        if ([stoAllowSpecialization,stoAllowTypeDef] * options <> []) and
 440           (m_delphi in current_settings.modeswitches) then
 441          dospecialize:=token in [_LSHARPBRACKET,_LT];
 442        if dospecialize and
 443            (def.typ=forwarddef) then
 444          begin
 445            if not assigned(srsym) or not (srsym.typ=typesym) then
 446              begin
 447                Message1(type_e_type_is_not_completly_defined,def.typename);
 448                def:=generrordef;
 449                dospecialize:=false;
 450              end;
 451          end;
 452        if dospecialize then
 453          begin
 454            if def.typ=forwarddef then
 455              def:=ttypesym(srsym).typedef;
 456            generate_specialization(def,stoParseClassParent in options,'');
 457          end
 458        else
 459          begin
 460            if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
 461              begin
 462                def:=current_specializedef
 463              end
 464            else if (def=current_genericdef) then
 465              begin
 466                def:=current_genericdef
 467              end
 468            { when parsing a nested specialization in non-Delphi mode it might
 469              use the name of the topmost generic without type paramaters, thus
 470              def will contain the generic definition, but we need a reference
 471              to the specialization of that generic }
 472            { TODO : only in non-Delphi modes? }
 473            else if assigned(current_structdef) and
 474                (df_specialization in current_structdef.defoptions) and
 475                return_specialization_of_generic(current_structdef,def,t2) then
 476              begin
 477                def:=t2
 478              end
 479            else if (df_generic in def.defoptions) and
 480                not
 481                  (
 482                    parse_generic and
 483                    (current_genericdef.typ in [recorddef,objectdef]) and
 484                    (
 485                      { if both defs belong to the same generic (e.g. both are
 486                        subtypes) then we must allow the usage }
 487                      defs_belong_to_same_generic(def,current_genericdef) or
 488                      { this is needed to correctly resolve "type Foo=SomeGeneric<T>"
 489                        declarations inside a generic }
 490                      sym_is_owned_by(srsym,tabstractrecorddef(current_genericdef).symtable)
 491                    )
 492                  )
 493                then
 494              begin
 495                Message(parser_e_no_generics_as_types);
 496                def:=generrordef;
 497              end
 498            else if (def.typ=undefineddef) and
 499                (sp_generic_dummy in srsym.symoptions) and
 500                parse_generic and
 501                (current_genericdef.typ in [recorddef,objectdef]) and
 502                (Pos(upper(srsym.realname),tabstractrecorddef(current_genericdef).objname^)=1) then
 503              begin
 504                if m_delphi in current_settings.modeswitches then
 505                  begin
 506                    Message(parser_e_no_generics_as_types);
 507                    def:=generrordef;
 508                  end
 509                else
 510                  def:=current_genericdef;
 511              end
 512            else if is_classhelper(def) and
 513                not (stoParseClassParent in options) then
 514              begin
 515                Message(parser_e_no_category_as_types);
 516                def:=generrordef
 517              end
 518          end;
 519      end;
 520
 521
 522    procedure parse_record_members;
 523
 524      function IsAnonOrLocal: Boolean;
 525        begin
 526          result:=(current_structdef.objname^='') or
 527                  not(symtablestack.stack^.next^.symtable.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]);
 528        end;
 529
 530      var
 531        pd : tprocdef;
 532        oldparse_only: boolean;
 533        member_blocktype : tblock_type;
 534        fields_allowed, is_classdef, classfields: boolean;
 535        vdoptions: tvar_dec_options;
 536      begin
 537        { empty record declaration ? }
 538        if (token=_SEMICOLON) then
 539          Exit;
 540
 541        current_structdef.symtable.currentvisibility:=vis_public;
 542        fields_allowed:=true;
 543        is_classdef:=false;
 544        classfields:=false;
 545        member_blocktype:=bt_general;
 546        repeat
 547          case token of
 548            _TYPE :
 549              begin
 550                consume(_TYPE);
 551                member_blocktype:=bt_type;
 552
 553                { local and anonymous records can not have inner types. skip top record symtable }
 554                if IsAnonOrLocal then
 555                  Message(parser_e_no_types_in_local_anonymous_records);
 556              end;
 557            _VAR :
 558              begin
 559                consume(_VAR);
 560                fields_allowed:=true;
 561                member_blocktype:=bt_general;
 562                classfields:=is_classdef;
 563                is_classdef:=false;
 564              end;
 565            _CONST:
 566              begin
 567                consume(_CONST);
 568                member_blocktype:=bt_const;
 569
 570                { local and anonymous records can not have constants. skip top record symtable }
 571                if IsAnonOrLocal then
 572                  Message(parser_e_no_consts_in_local_anonymous_records);
 573              end;
 574            _ID, _CASE, _OPERATOR :
 575              begin
 576                case idtoken of
 577                  _PRIVATE :
 578                    begin
 579                       consume(_PRIVATE);
 580                       current_structdef.symtable.currentvisibility:=vis_private;
 581                       include(current_structdef.objectoptions,oo_has_private);
 582                       fields_allowed:=true;
 583                       is_classdef:=false;
 584                       classfields:=false;
 585                       member_blocktype:=bt_general;
 586                     end;
 587                   _PROTECTED :
 588                     begin
 589                       consume(_PROTECTED);
 590                       current_structdef.symtable.currentvisibility:=vis_protected;
 591                       include(current_structdef.objectoptions,oo_has_protected);
 592                       fields_allowed:=true;
 593                       is_classdef:=false;
 594                       classfields:=false;
 595                       member_blocktype:=bt_general;
 596                     end;
 597                   _PUBLIC :
 598                     begin
 599                       consume(_PUBLIC);
 600                       current_structdef.symtable.currentvisibility:=vis_public;
 601                       fields_allowed:=true;
 602                       is_classdef:=false;
 603                       classfields:=false;
 604                       member_blocktype:=bt_general;
 605                     end;
 606                   _PUBLISHED :
 607                     begin
 608                       Message(parser_e_no_record_published);
 609                       consume(_PUBLISHED);
 610                       current_structdef.symtable.currentvisibility:=vis_published;
 611                       fields_allowed:=true;
 612                       is_classdef:=false;
 613                       classfields:=false;
 614                       member_blocktype:=bt_general;
 615                     end;
 616                   _STRICT :
 617                     begin
 618                        consume(_STRICT);
 619                        if token=_ID then
 620                          begin
 621                            case idtoken of
 622                              _PRIVATE:
 623                                begin
 624                                  consume(_PRIVATE);
 625                                  current_structdef.symtable.currentvisibility:=vis_strictprivate;
 626                                  include(current_structdef.objectoptions,oo_has_strictprivate);
 627                                end;
 628                              _PROTECTED:
 629                                begin
 630                                  consume(_PROTECTED);
 631                                  current_structdef.symtable.currentvisibility:=vis_strictprotected;
 632                                  include(current_structdef.objectoptions,oo_has_strictprotected);
 633                                end;
 634                              else
 635                                message(parser_e_protected_or_private_expected);
 636                            end;
 637                          end
 638                        else
 639                          message(parser_e_protected_or_private_expected);
 640                        fields_allowed:=true;
 641                        is_classdef:=false;
 642                        classfields:=false;
 643                        member_blocktype:=bt_general;
 644                     end
 645                    else
 646                    if is_classdef and (idtoken=_OPERATOR) then
 647                      begin
 648                        pd:=parse_record_method_dec(current_structdef,is_classdef);
 649                        fields_allowed:=false;
 650                        is_classdef:=false;
 651                      end
 652                      else
 653                      begin
 654                        if member_blocktype=bt_general then
 655                          begin
 656                            if (not fields_allowed)and(idtoken<>_CASE) then
 657                              Message(parser_e_field_not_allowed_here);
 658                            vdoptions:=[vd_record];
 659                            if classfields then
 660                              include(vdoptions,vd_class);
 661                            read_record_fields(vdoptions,nil);
 662                          end
 663                        else if member_blocktype=bt_type then
 664                          types_dec(true)
 665                        else if member_blocktype=bt_const then
 666                          consts_dec(true,true)
 667                        else
 668                          internalerror(201001110);
 669                      end;
 670                end;
 671              end;
 672            _PROPERTY :
 673              begin
 674                if IsAnonOrLocal then
 675                  Message(parser_e_no_properties_in_local_anonymous_records);
 676                struct_property_dec(is_classdef);
 677                fields_allowed:=false;
 678                is_classdef:=false;
 679              end;
 680            _CLASS:
 681              begin
 682                is_classdef:=false;
 683                { read class method/field/property }
 684                consume(_CLASS);
 685                { class modifier is only allowed for procedures, functions, }
 686                { constructors, destructors, fields and properties          }
 687                if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and
 688                   not((token=_ID) and (idtoken=_OPERATOR)) then
 689                  Message(parser_e_procedure_or_function_expected);
 690
 691                if IsAnonOrLocal then
 692                  Message(parser_e_no_class_in_local_anonymous_records);
 693
 694                is_classdef:=true;
 695              end;
 696            _PROCEDURE,
 697            _FUNCTION:
 698              begin
 699                if IsAnonOrLocal then
 700                  Message(parser_e_no_methods_in_local_anonymous_records);
 701                pd:=parse_record_method_dec(current_structdef,is_classdef);
 702                fields_allowed:=false;
 703                is_classdef:=false;
 704              end;
 705            _CONSTRUCTOR :
 706              begin
 707                if IsAnonOrLocal then
 708                  Message(parser_e_no_methods_in_local_anonymous_records);
 709                if not is_classdef and (current_structdef.symtable.currentvisibility <> vis_public) then
 710                  Message(parser_w_constructor_should_be_public);
 711
 712                { only 1 class constructor is allowed }
 713                if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then
 714                  Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^);
 715
 716                oldparse_only:=parse_only;
 717                parse_only:=true;
 718                if is_classdef then
 719                  pd:=class_constructor_head(current_structdef)
 720                else
 721                  begin
 722                    pd:=constructor_head;
 723                    if pd.minparacount = 0 then
 724                      MessagePos(pd.procsym.fileinfo,parser_e_no_parameterless_constructor_in_records);
 725                  end;
 726
 727                parse_only:=oldparse_only;
 728                fields_allowed:=false;
 729                is_classdef:=false;
 730              end;
 731            _DESTRUCTOR :
 732              begin
 733                if IsAnonOrLocal then
 734                  Message(parser_e_no_methods_in_local_anonymous_records);
 735                if not is_classdef then
 736                  Message(parser_e_no_destructor_in_records);
 737
 738                { only 1 class destructor is allowed }
 739                if is_classdef and (oo_has_class_destructor in current_structdef.objectoptions) then
 740                  Message1(parser_e_only_one_class_destructor_allowed, current_structdef.objrealname^);
 741
 742                oldparse_only:=parse_only;
 743                parse_only:=true;
 744                if is_classdef then
 745                  pd:=class_destructor_head(current_structdef)
 746                else
 747                  pd:=destructor_head;
 748
 749                parse_only:=oldparse_only;
 750                fields_allowed:=false;
 751                is_classdef:=false;
 752              end;
 753            _END :
 754              begin
 755{$ifdef jvm}
 756                add_java_default_record_methods_intf(trecorddef(current_structdef));
 757{$endif}
 758                if target_info.system in systems_typed_constants_node_init then
 759                  add_typedconst_init_routine(current_structdef);
 760                consume(_END);
 761                break;
 762              end;
 763            else
 764              consume(_ID); { Give a ident expected message, like tp7 }
 765          end;
 766        until false;
 767      end;
 768
 769    { reads a record declaration }
 770    function record_dec(const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList):tdef;
 771      var
 772         old_current_structdef: tabstractrecorddef;
 773         old_current_genericdef,
 774         old_current_specializedef: tstoreddef;
 775         old_parse_generic: boolean;
 776         recst: trecordsymtable;
 777      begin
 778         old_current_structdef:=current_structdef;
 779         old_current_genericdef:=current_genericdef;
 780         old_current_specializedef:=current_specializedef;
 781         old_parse_generic:=parse_generic;
 782
 783         current_genericdef:=nil;
 784         current_specializedef:=nil;
 785         { create recdef }
 786         if (n<>'') or
 787            not(target_info.system in systems_jvm) then
 788           begin
 789             recst:=trecordsymtable.create(n,current_settings.packrecords);
 790             { can't use recst.realname^ instead of n, because recst.realname is
 791               nil in case of an empty name }
 792             current_structdef:=trecorddef.create(n,recst);
 793           end
 794         else
 795           begin
 796             { for the JVM target records always need a name, because they are
 797               represented by a class }
 798             recst:=trecordsymtable.create(current_module.realmodulename^+'__fpc_intern_recname_'+tostr(current_module.deflist.count),current_settings.packrecords);
 799             current_structdef:=trecorddef.create(recst.name^,recst);
 800           end;
 801         result:=current_structdef;
 802         { insert in symtablestack }
 803         symtablestack.push(recst);
 804
 805         { usage of specialized type inside its generic template }
 806         if assigned(genericdef) then
 807           current_specializedef:=current_structdef
 808         { reject declaration of generic class inside generic class }
 809         else if assigned(genericlist) then
 810           current_genericdef:=current_structdef;
 811
 812         { nested types of specializations are specializations as well }
 813         if assigned(old_current_structdef) and
 814             (df_specialization in old_current_structdef.defoptions) then
 815           include(current_structdef.defoptions,df_specialization);
 816         if assigned(old_current_structdef) and
 817             (df_generic in old_current_structdef.defoptions) then
 818           begin
 819             include(current_structdef.defoptions,df_generic);
 820             current_genericdef:=current_structdef;
 821           end;
 822
 823         insert_generic_parameter_types(current_structdef,genericdef,genericlist);
 824         { when we are parsing a generic already then this is a generic as
 825           well }
 826         if old_parse_generic then
 827           include(current_structdef.defoptions, df_generic);
 828         parse_generic:=(df_generic in current_structdef.defoptions);
 829         { in non-Delphi modes we need a strict private symbol without type
 830           count and type parameters in the name to simply resolving }
 831         maybe_insert_generic_rename_symbol(n,genericlist);
 832
 833         if m_advanced_records in current_settings.modeswitches then
 834           begin
 835             parse_record_members;
 836           end
 837         else
 838           begin
 839             read_record_fields([vd_record],nil);
 840{$ifdef jvm}
 841             { we need a constructor to create temps, a deep copy helper, ... }
 842             add_java_default_record_methods_intf(trecorddef(current_structdef));
 843{$endif}
 844             if target_info.system in systems_typed_constants_node_init then
 845               add_typedconst_init_routine(current_structdef);
 846             consume(_END);
 847            end;
 848         { make the record size aligned (has to be done before inserting the
 849           parameters, because that may depend on the record's size) }
 850         recst.addalignmentpadding;
 851         { don't keep track of procdefs in a separate list, because the
 852           compiler may add additional procdefs (e.g. property wrappers for
 853           the jvm backend) }
 854         insert_record_hidden_paras(trecorddef(current_structdef));
 855         { restore symtable stack }
 856         symtablestack.pop(recst);
 857         if trecorddef(current_structdef).is_packed and is_managed_type(current_structdef) then
 858           Message(type_e_no_packed_inittable);
 859         { restore old state }
 860         parse_generic:=old_parse_generic;
 861         current_structdef:=old_current_structdef;
 862         current_genericdef:=old_current_genericdef;
 863         current_specializedef:=old_current_specializedef;
 864      end;
 865
 866
 867    { reads a type definition and returns a pointer to it }
 868    procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean;hadtypetoken:boolean);
 869      var
 870        pt : tnode;
 871        tt2 : tdef;
 872        aktenumdef : tenumdef;
 873        s : TIDString;
 874        l,v : TConstExprInt;
 875        oldpackrecords : longint;
 876        defpos,storepos : tfileposinfo;
 877        name: TIDString;
 878
 879        procedure expr_type;
 880        var
 881           pt1,pt2 : tnode;
 882           lv,hv   : TConstExprInt;
 883           old_block_type : tblock_type;
 884           dospecialize : boolean;
 885           newdef  : tdef;
 886        begin
 887           old_block_type:=block_type;
 888           dospecialize:=false;
 889           { use of current parsed object:
 890             classes, objects, records can be used also in themself }
 891           if (token=_ID) then
 892             if try_parse_structdef_nested_type(def,current_structdef,false) then
 893               exit;
 894           { Generate a specialization in FPC mode? }
 895           dospecialize:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_SPECIALIZE);
 896           { we can't accept a equal in type }
 897           pt1:=comp_expr(false,true);
 898           if not dospecialize and
 899              try_to_consume(_POINTPOINT) then
 900             begin
 901               { get high value of range }
 902               pt2:=comp_expr(false,false);
 903               { make both the same type or give an error. This is not
 904                 done when both are integer values, because typecasting
 905                 between -3200..3200 will result in a signed-unsigned
 906                 conflict and give a range check error (PFV) }
 907               if not(is_integer(pt1.resultdef) and is_integer(pt2.resultdef)) then
 908                 inserttypeconv(pt1,pt2.resultdef);
 909               { both must be evaluated to constants now }
 910               if (pt1.nodetype=ordconstn) and
 911                  (pt2.nodetype=ordconstn) then
 912                 begin
 913                   lv:=tordconstnode(pt1).value;
 914                   hv:=tordconstnode(pt2).value;
 915                   { Check bounds }
 916                   if hv<lv then
 917                     message(parser_e_upper_lower_than_lower)
 918                   else if (lv.signed and (lv.svalue<0)) and (not hv.signed and (hv.uvalue>qword(high(int64)))) then
 919                     message(type_e_cant_eval_constant_expr)
 920                   else
 921                     begin
 922                       { All checks passed, create the new def }
 923                       case pt1.resultdef.typ of
 924                         enumdef :
 925                           def:=tenumdef.create_subrange(tenumdef(pt1.resultdef),lv.svalue,hv.svalue);
 926                         orddef :
 927                           begin
 928                             if is_char(pt1.resultdef) then
 929                               def:=torddef.create(uchar,lv,hv)
 930                             else
 931                               if is_boolean(pt1.resultdef) then
 932                                 def:=torddef.create(pasbool8,lv,hv)
 933                               else if is_signed(pt1.resultdef) then
 934                                 def:=torddef.create(range_to_basetype(lv,hv),lv,hv)
 935                               else
 936                                 def:=torddef.create(range_to_basetype(lv,hv),lv,hv);
 937                           end;
 938                       end;
 939                     end;
 940                 end
 941               else
 942                 Message(sym_e_error_in_type_def);
 943               pt2.free;
 944             end
 945           else
 946             begin
 947               { a simple type renaming or generic specialization }
 948               if (pt1.nodetype=typen) then
 949                 begin
 950                   def:=ttypenode(pt1).resultdef;
 951                   { Delphi mode specialization? }
 952                   if (m_delphi in current_settings.modeswitches) then
 953                     dospecialize:=token=_LSHARPBRACKET
 954                   else
 955                     { in non-Delphi modes we might get a inline specialization
 956                       without "specialize" or "<T>" of the same type we're
 957                       currently parsing, so we need to handle that special }
 958                     newdef:=nil;
 959                     if not dospecialize and
 960                         assigned(ttypenode(pt1).typesym) and
 961                         (ttypenode(pt1).typesym.typ=typesym) and
 962                         (sp_generic_dummy in ttypenode(pt1).typesym.symoptions) and
 963                         assigned(current_structdef) and
 964                         (
 965                           (
 966                             not (m_delphi in current_settings.modeswitches) and
 967                             (ttypesym(ttypenode(pt1).typesym).typedef.typ=undefineddef) and
 968                             (df_generic in current_structdef.defoptions) and
 969                             (ttypesym(ttypenode(pt1).typesym).typedef.owner=current_structdef.owner) and
 970                             (upper(ttypenode(pt1).typesym.realname)=copy(current_structdef.objname^,1,pos('$',current_structdef.objname^)-1))
 971                           ) or (
 972                             { this could be a nested specialization which uses
 973                               the type name of a surrounding generic to
 974                               reference the specialization of said surrounding
 975                               class }
 976                             (df_specialization in current_structdef.defoptions) and
 977                             return_specialization_of_generic(current_structdef,ttypesym(ttypenode(pt1).typesym).typedef,newdef)
 978                           )
 979                         )
 980                         then
 981                       begin
 982                         if assigned(newdef) then
 983                           def:=newdef
 984                         else
 985                           def:=current_structdef;
 986                         if assigned(def) then
 987                           { handle nested types }
 988                           post_comp_expr_gendef(def)
 989                         else
 990                           def:=generrordef;
 991                       end;
 992                   if dospecialize then
 993                     begin
 994                       generate_specialization(def,false,name);
 995                       { handle nested types }
 996                       if assigned(def) then
 997                         post_comp_expr_gendef(def);
 998                     end
 999                   else
1000                     begin
1001                       if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
1002                         begin
1003                           def:=current_specializedef
1004                         end
1005                       else if (def=current_genericdef) then
1006                         begin
1007                           def:=current_genericdef
1008                         end
1009                       else if (df_generic in def.defoptions) and
1010                           { TODO : check once nested generics are allowed }
1011                           not
1012                             (
1013                               parse_generic and
1014                               (current_genericdef.typ in [recorddef,objectdef]) and
1015                               (def.typ in [recorddef,objectdef]) and
1016                               (
1017                                 { if both defs belong to the same generic (e.g. both are
1018                                   subtypes) then we must allow the usage }
1019                                 defs_belong_to_same_generic(def,current_genericdef) or
1020                                 { this is needed to correctly resolve "type Foo=SomeGeneric<T>"
1021                                   declarations inside a generic }
1022                                 (
1023                                   (ttypenode(pt1).typesym<>nil) and
1024                                   sym_is_owned_by(ttypenode(pt1).typesym,tabstractrecorddef(current_genericdef).symtable)
1025                                 )
1026                               )
1027                             )
1028                           then
1029                         begin
1030                           Message(parser_e_no_generics_as_types);
1031                           def:=generrordef;
1032                         end
1033                       else if is_classhelper(def) then
1034                         begin
1035                           Message(parser_e_no_category_as_types);
1036                           def:=generrordef
1037                         end
1038                     end;
1039                 end
1040               else
1041                 Message(sym_e_error_in_type_def);
1042             end;
1043           pt1.free;
1044           block_type:=old_block_type;
1045        end;
1046
1047
1048      procedure set_dec;
1049        begin
1050          consume(_SET);
1051          consume(_OF);
1052          read_anon_type(tt2,true);
1053          if assigned(tt2) then
1054           begin
1055             case tt2.typ of
1056               { don't forget that min can be negativ  PM }
1057               enumdef :
1058                 if (tenumdef(tt2).min>=0) and
1059                    (tenumdef(tt2).max<=255) then
1060                  // !! def:=tsetdef.create(tt2,tenumdef(tt2.def).min,tenumdef(tt2.def).max))
1061                  def:=tsetdef.create(tt2,tenumdef(tt2).min,tenumdef(tt2).max)
1062                 else
1063                  Message(sym_e_ill_type_decl_set);
1064               orddef :
1065                 begin
1066                   if (torddef(tt2).ordtype<>uvoid) and
1067                      (torddef(tt2).ordtype<>uwidechar) and
1068                      (torddef(tt2).low>=0) then
1069                     // !! def:=tsetdef.create(tt2,torddef(tt2.def).low,torddef(tt2.def).high))
1070                     if Torddef(tt2).high>int64(high(byte)) then
1071                       message(sym_e_ill_type_decl_set)
1072                     else
1073                       def:=tsetdef.create(tt2,torddef(tt2).low.svalue,torddef(tt2).high.svalue)
1074                   else
1075                     Message(sym_e_ill_type_decl_set);
1076                 end;
1077               else
1078                 Message(sym_e_ill_type_decl_set);
1079             end;
1080           end
1081          else
1082           def:=generrordef;
1083        end;
1084
1085
1086      procedure array_dec(is_packed:boolean;genericdef:tstoreddef;genericlist:TFPObjectList);
1087        var
1088          lowval,
1089          highval   : TConstExprInt;
1090          indexdef  : tdef;
1091          hdef      : tdef;
1092          arrdef    : tarraydef;
1093
1094        procedure setdefdecl(def:tdef);
1095          begin
1096            case def.typ of
1097              enumdef :
1098                begin
1099                  lowval:=tenumdef(def).min;
1100                  highval:=tenumdef(def).max;
1101                  if (m_fpc in current_settings.modeswitches) and
1102                     (tenumdef(def).has_jumps) then
1103                   Message(type_e_array_index_enums_with_assign_not_possible);
1104                  indexdef:=def;
1105                end;
1106              orddef :
1107                begin
1108                  if torddef(def).ordtype in [uchar,
1109                    u8bit,u16bit,
1110                    s8bit,s16bit,s32bit,
1111{$ifdef cpu64bitaddr}
1112                    u32bit,s64bit,
1113{$endif cpu64bitaddr}
1114                    pasbool8,pasbool16,pasbool32,pasbool64,
1115                    bool8bit,bool16bit,bool32bit,bool64bit,
1116                    uwidechar] then
1117                    begin
1118                       lowval:=torddef(def).low;
1119                       highval:=torddef(def).high;
1120                       indexdef:=def;
1121                    end
1122                  else
1123                    Message1(parser_e_type_cant_be_used_in_array_index,def.typename);
1124                end;
1125              else
1126                Message(sym_e_error_in_type_def);
1127            end;
1128          end;
1129
1130        var
1131          old_current_genericdef,
1132          old_current_specializedef: tstoreddef;
1133          first,
1134          old_parse_generic: boolean;
1135        begin
1136           old_current_genericdef:=current_genericdef;
1137           old_current_specializedef:=current_specializedef;
1138           old_parse_generic:=parse_generic;
1139
1140           current_genericdef:=nil;
1141           current_specializedef:=nil;
1142           first:=true;
1143           arrdef:=tarraydef.create(0,0,s32inttype);
1144           consume(_ARRAY);
1145
1146           { usage of specialized type inside its generic template }
1147           if assigned(genericdef) then
1148             current_specializedef:=arrdef
1149           { reject declaration of generic class inside generic class }
1150           else if assigned(genericlist) then
1151             current_genericdef:=arrdef;
1152           symtablestack.push(arrdef.symtable);
1153           insert_generic_parameter_types(arrdef,genericdef,genericlist);
1154           { there are two possibilties for the following to be true:
1155             * the array declaration itself is generic
1156             * the array is declared inside a generic
1157             in both cases we need "parse_generic" and "current_genericdef"
1158             so that e.g. specializations of another generic inside the
1159             current generic can be used (either inline ones or "type" ones) }
1160           parse_generic:=(df_generic in arrdef.defoptions) or old_parse_generic;
1161           if parse_generic and not assigned(current_genericdef) then
1162             current_genericdef:=old_current_genericdef;
1163
1164           { open array? }
1165           if try_to_consume(_LECKKLAMMER) then
1166             begin
1167                { defaults }
1168                indexdef:=generrordef;
1169                { use defaults which don't overflow the compiler }
1170                lowval:=0;
1171                highval:=0;
1172                repeat
1173                  { read the expression and check it, check apart if the
1174                    declaration is an enum declaration because that needs to
1175                    be parsed by readtype (PFV) }
1176                  if token=_LKLAMMER then
1177                   begin
1178                     read_anon_type(hdef,true);
1179                     setdefdecl(hdef);
1180                   end
1181                  else
1182                   begin
1183                     pt:=expr(true);
1184                     if pt.nodetype=typen then
1185                       setdefdecl(pt.resultdef)
1186                     else
1187                       begin
1188                         if pt.nodetype=rangen then
1189                           begin
1190                             { pure ordconstn expressions can be checked for
1191                               generics as well, but don't give an error in case
1192                               of parsing a generic if that isn't yet the case }
1193                             if (trangenode(pt).left.nodetype=ordconstn) and
1194                                (trangenode(pt).right.nodetype=ordconstn) then
1195                               begin
1196                                 { make both the same type or give an error. This is not
1197                                   done when both are integer values, because typecasting
1198

Large files files are truncated, but you can click here to view the full file