Implement support for parsing "generic [class] procedure" and "generic [class] function" in non-Delphi modes. Since "generic" is a prefix it is quite ugly to implement, but from a Pascal language point of view it fits better than "procedure generic xyz".

Supporting such a prefix of course means that all section handling code ("var", "type", etc.) needs to respect the case of a "generic" token followed by "function", "procedure" or "class" and thus abort doing its own business.
Maybe I'll find the time somewhen in the future to rework the parser (plus scanner?) a bit so that code like this gets more easy to add and more importantly less ugly.

pdecsub.pas:
  * extend parse_proc_dec() and parse_record_method_dec() so that they can be told that they are supposed to handle the to be parsed function/procedure/method header as a generic
pdecvar.pas:
  + new entry for tvar_dec_option named "vd_check_generic" to tell read_var_decls() and read_record_fields() to look out for "generic"
  * extend read_var_decls() and read_record_fields() to check for "generic" if needed and to clean up correctly if it is encountered
pdecl.pas:
  * the section handling procedures types_dec(), resourcestring_dec(), var_dec(), threadvar_dec() and consts_dec() all return whether they had encountered a "generic" token that was followed by one of $
pdecobj.pas:
  * extend method_dec() to take a parameter that says whether the method is supposed to be a generic one
  * parse_object_members: while read_record_fields() can handle "generic" we also need to handle the case of "generic" if no fields are allowed anymore
psub.pas:
  * extend read_proc() by the possibility to tell it that the procedure/function to be parsed is supposed to be generic
  * adjust read_declarations() and read_interface_declarations() to keep track of parsed "generic" tokens and to pass them on accordingly
ptype.pas:
  * parse_record_members: same remark as for pdecobj.parse_object_members

git-svn-id: trunk@32380 -

compiler/pdecl.pas

@@ -37,15 +37,15 @@ interface
 
     function  readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym;
 
-    procedure const_dec;
-    procedure consts_dec(in_structure, allow_typed_const: boolean);
+    procedure const_dec(out had_generic:boolean);
+    procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean);
     procedure label_dec;
-    procedure type_dec;
-    procedure types_dec(in_structure: boolean);
-    procedure var_dec;
-    procedure threadvar_dec;
+    procedure type_dec(out had_generic:boolean);
+    procedure types_dec(in_structure: boolean;out had_generic:boolean);
+    procedure var_dec(out had_generic:boolean);
+    procedure threadvar_dec(out had_generic:boolean);
     procedure property_dec;
-    procedure resourcestring_dec;
+    procedure resourcestring_dec(out had_generic:boolean);
 
 implementation
 
@@ -181,13 +181,13 @@ implementation
         readconstant:=hp;
       end;
 
-    procedure const_dec;
+    procedure const_dec(out had_generic:boolean);
       begin
         consume(_CONST);
-        consts_dec(false,true);
+        consts_dec(false,true,had_generic);
       end;
 
-    procedure consts_dec(in_structure, allow_typed_const: boolean);
+    procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean);
       var
          orgname : TIDString;
          hdef : tdef;
@@ -197,15 +197,20 @@ implementation
          storetokenpos,filepos : tfileposinfo;
          nodetype : tnodetype;
          old_block_type : tblock_type;
+         first,
+         isgeneric,
          skipequal : boolean;
          tclist : tasmlist;
          varspez : tvarspez;
       begin
          old_block_type:=block_type;
          block_type:=bt_const;
+         had_generic:=false;
+         first:=true;
          repeat
            orgname:=orgpattern;
            filepos:=current_tokenpos;
+           isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC);
            consume(_ID);
            case token of
 
@@ -314,9 +319,17 @@ implementation
                 end;
 
               else
-                { generate an error }
-                consume(_EQ);
+                if not first and isgeneric and (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
+                  begin
+                    had_generic:=true;
+                    break;
+                  end
+                else
+                  { generate an error }
+                  consume(_EQ);
            end;
+
+           first:=false;
          until (token<>_ID) or
                (in_structure and
                 ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
@@ -367,7 +380,7 @@ implementation
          consume(_SEMICOLON);
       end;
 
-    procedure types_dec(in_structure: boolean);
+    procedure types_dec(in_structure: boolean;out had_generic:boolean);
 
       function determine_generic_def(name:tidstring):tstoreddef;
         var
@@ -435,6 +448,7 @@ implementation
          old_block_type : tblock_type;
          old_checkforwarddefs: TFPObjectList;
          objecttype : tobjecttyp;
+         first,
          isgeneric,
          isunique,
          istyperenaming : boolean;
@@ -456,6 +470,7 @@ implementation
          current_module.checkforwarddefs:=TFPObjectList.Create(false);
          block_type:=bt_type;
          hdef:=nil;
+         first:=true;
          repeat
            defpos:=current_tokenpos;
            istyperenaming:=false;
@@ -463,7 +478,9 @@ implementation
            generictokenbuf:=nil;
 
            { fpc generic declaration? }
-           isgeneric:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC);
+           if first then
+             had_generic:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC);
+           isgeneric:=had_generic;
 
            typename:=pattern;
            orgtypename:=orgpattern;
@@ -897,6 +914,18 @@ implementation
                hdef.typesym:=newtype;
                generictypelist.free;
              end;
+
+           if not (m_delphi in current_settings.modeswitches) and
+               (token=_ID) and (idtoken=_GENERIC) then
+             begin
+               had_generic:=true;
+               consume(_ID);
+               if token in [_PROCEDURE,_FUNCTION,_CLASS] then
+                 break;
+             end
+           else
+             had_generic:=false;
+           first:=false;
          until (token<>_ID) or
                (in_structure and
                 ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
@@ -912,19 +941,19 @@ implementation
 
 
     { reads a type declaration to the symbol table }
-    procedure type_dec;
+    procedure type_dec(out had_generic:boolean);
       begin
         consume(_TYPE);
-        types_dec(false);
+        types_dec(false,had_generic);
       end;
 
 
-    procedure var_dec;
+    procedure var_dec(out had_generic:boolean);
     { parses variable declarations and inserts them in }
     { the top symbol table of symtablestack         }
       begin
         consume(_VAR);
-        read_var_decls([]);
+        read_var_decls([vd_check_generic],had_generic);
       end;
 
 
@@ -946,7 +975,7 @@ implementation
       end;
 
 
-    procedure threadvar_dec;
+    procedure threadvar_dec(out had_generic:boolean);
     { parses thread variable declarations and inserts them in }
     { the top symbol table of symtablestack                }
       begin
@@ -954,16 +983,16 @@ implementation
         if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
           message(parser_e_threadvars_only_sg);
         if f_threading in features then
-          read_var_decls([vd_threadvar])
+          read_var_decls([vd_threadvar,vd_check_generic],had_generic)
         else
           begin
             Message1(parser_f_unsupported_feature,featurestr[f_threading]);
-            read_var_decls([]);
+            read_var_decls([vd_check_generic],had_generic);
           end;
       end;
 
 
-    procedure resourcestring_dec;
+    procedure resourcestring_dec(out had_generic:boolean);
       var
          orgname : TIDString;
          p : tnode;
@@ -973,17 +1002,22 @@ implementation
          old_block_type : tblock_type;
          sp : pchar;
          sym : tsym;
+         first,
+         isgeneric : boolean;
       begin
          if target_info.system in systems_managed_vm then
            message(parser_e_feature_unsupported_for_vm);
          consume(_RESOURCESTRING);
          if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
            message(parser_e_resourcestring_only_sg);
+         first:=true;
+         had_generic:=false;
          old_block_type:=block_type;
          block_type:=bt_const;
          repeat
            orgname:=orgpattern;
            filepos:=current_tokenpos;
+           isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC);
            consume(_ID);
            case token of
              _EQ:
@@ -1035,8 +1069,17 @@ implementation
                    consume(_SEMICOLON);
                    p.free;
                 end;
-              else consume(_EQ);
+              else
+                if not first and isgeneric and
+                    (token in [_PROCEDURE, _FUNCTION, _CLASS]) then
+                  begin
+                    had_generic:=true;
+                    break;
+                  end
+                else
+                  consume(_EQ);
            end;
+           first:=false;
          until token<>_ID;
          block_type:=old_block_type;
       end;

compiler/pdecobj.pas

@@ -33,7 +33,7 @@ interface
     function object_dec(objecttype:tobjecttyp;const n:tidstring;objsym:tsym;genericdef:tstoreddef;genericlist:tfphashobjectlist;fd : tobjectdef;helpertype:thelpertype) : tobjectdef;
 
     { parses a (class) method declaration }
-    function method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef;
+    function method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef;
 
     function class_constructor_head(astruct: tabstractrecorddef):tprocdef;
     function class_destructor_head(astruct: tabstractrecorddef):tprocdef;
@@ -810,7 +810,7 @@ implementation
       end;
 
 
-    function method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef;
+    function method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef;
 
       procedure chkobjc(pd: tprocdef);
         begin
@@ -874,7 +874,7 @@ implementation
 
               oldparse_only:=parse_only;
               parse_only:=true;
-              result:=parse_proc_dec(is_classdef,astruct);
+              result:=parse_proc_dec(is_classdef,astruct,hadgeneric);
 
               { this is for error recovery as well as forward }
               { interface mappings, i.e. mapping to a method  }
@@ -1019,6 +1019,7 @@ implementation
       var
         typedconstswritable: boolean;
         object_member_blocktype : tblock_type;
+        hadgeneric,
         fields_allowed, is_classdef, class_fields, is_final, final_fields: boolean;
         vdoptions: tvar_dec_options;
         fieldlist: tfpobjectlist;
@@ -1114,6 +1115,7 @@ implementation
         class_fields:=false;
         is_final:=false;
         final_fields:=false;
+        hadgeneric:=false;
         object_member_blocktype:=bt_general;
         fieldlist:=tfpobjectlist.create(false);
         repeat
@@ -1214,33 +1216,49 @@ implementation
                       begin
                         if object_member_blocktype=bt_general then
                           begin
-                            if is_interface(current_structdef) or
-                               is_objc_protocol_or_category(current_structdef) or
-                               (
-                                 is_objectpascal_helper(current_structdef) and
-                                 not class_fields
-                               ) or
-                               (is_javainterface(current_structdef) and
-                                not(class_fields and final_fields)) then
-                              Message(parser_e_no_vars_in_interfaces);
-
-                            if (current_structdef.symtable.currentvisibility=vis_published) and
-                               not(oo_can_have_published in current_structdef.objectoptions) then
-                              Message(parser_e_cant_have_published);
-                            if (not fields_allowed) then
-                              Message(parser_e_field_not_allowed_here);
-
-                            vdoptions:=[vd_object];
-                            if class_fields then
-                              include(vdoptions,vd_class);
-                            if is_class(current_structdef) then
-                              include(vdoptions,vd_canreorder);
-                            if final_fields then
-                              include(vdoptions,vd_final);
-                            read_record_fields(vdoptions,fieldlist,nil);
+                            if (idtoken=_GENERIC) and
+                                not (m_delphi in current_settings.modeswitches) and
+                                not fields_allowed then
+                              begin
+                                if hadgeneric then
+                                  Message(parser_e_procedure_or_function_expected);
+                                consume(_ID);
+                                hadgeneric:=true;
+                                if not (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
+                                  Message(parser_e_procedure_or_function_expected);
+                              end
+                            else
+                              begin
+                                if is_interface(current_structdef) or
+                                   is_objc_protocol_or_category(current_structdef) or
+                                   (
+                                     is_objectpascal_helper(current_structdef) and
+                                     not class_fields
+                                   ) or
+                                   (is_javainterface(current_structdef) and
+                                    not(class_fields and final_fields)) then
+                                  Message(parser_e_no_vars_in_interfaces);
+
+                                if (current_structdef.symtable.currentvisibility=vis_published) and
+                                   not(oo_can_have_published in current_structdef.objectoptions) then
+                                  Message(parser_e_cant_have_published);
+                                if (not fields_allowed) then
+                                  Message(parser_e_field_not_allowed_here);
+
+                                vdoptions:=[vd_object];
+                                if not (m_delphi in current_settings.modeswitches) then
+                                  include(vdoptions,vd_check_generic);
+                                if class_fields then
+                                  include(vdoptions,vd_class);
+                                if is_class(current_structdef) then
+                                  include(vdoptions,vd_canreorder);
+                                if final_fields then
+                                  include(vdoptions,vd_final);
+                                read_record_fields(vdoptions,fieldlist,nil,hadgeneric);
+                              end;
                           end
                         else if object_member_blocktype=bt_type then
-                          types_dec(true)
+                          types_dec(true,hadgeneric)
                         else if object_member_blocktype=bt_const then
                           begin
                             typedconstswritable:=false;
@@ -1251,7 +1269,7 @@ implementation
                                 typedconstswritable:=cs_typed_const_writable in current_settings.localswitches;
                                 exclude(current_settings.localswitches,cs_typed_const_writable);
                               end;
-                            consts_dec(true,not is_javainterface(current_structdef));
+                            consts_dec(true,not is_javainterface(current_structdef),hadgeneric);
                             if final_fields and
                                typedconstswritable then
                               include(current_settings.localswitches,cs_typed_const_writable);
@@ -1276,9 +1294,10 @@ implementation
             _CONSTRUCTOR,
             _DESTRUCTOR :
               begin
-                method_dec(current_structdef,is_classdef);
+                method_dec(current_structdef,is_classdef,hadgeneric);
                 fields_allowed:=false;
                 is_classdef:=false;
+                hadgeneric:=false;
               end;
             _END :
               begin

compiler/pdecsub.pas

@@ -78,11 +78,11 @@ interface
     procedure parse_object_proc_directives(pd:tabstractprocdef);
     procedure parse_record_proc_directives(pd:tabstractprocdef);
     function  parse_proc_head(astruct:tabstractrecorddef;potype:tproctypeoption;isgeneric:boolean;genericdef:tdef;generictypelist:tfphashobjectlist;out pd:tprocdef):boolean;
-    function  parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef):tprocdef;
+    function  parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef;isgeneric:boolean):tprocdef;
     procedure parse_proc_dec_finish(pd:tprocdef;isclassmethod:boolean);
 
     { parse a record method declaration (not a (class) constructor/destructor) }
-    function parse_record_method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef;
+    function parse_record_method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef;
 
     procedure insert_record_hidden_paras(astruct: trecorddef);
 
@@ -1457,7 +1457,7 @@ implementation
          end;
       end;
 
-    function parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef):tprocdef;
+    function parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef;isgeneric:boolean):tprocdef;
       var
         pd : tprocdef;
         old_block_type : tblock_type;
@@ -1480,7 +1480,7 @@ implementation
           _FUNCTION :
             begin
               consume(_FUNCTION);
-              if parse_proc_head(astruct,potype_function,false,nil,nil,pd) then
+              if parse_proc_head(astruct,potype_function,isgeneric,nil,nil,pd) then
                 begin
                   { pd=nil when it is a interface mapping }
                   if assigned(pd) then
@@ -1500,7 +1500,7 @@ implementation
           _PROCEDURE :
             begin
               consume(_PROCEDURE);
-              if parse_proc_head(astruct,potype_procedure,false,nil,nil,pd) then
+              if parse_proc_head(astruct,potype_procedure,isgeneric,nil,nil,pd) then
                 begin
                   { pd=nil when it is an interface mapping }
                   if assigned(pd) then
@@ -1578,13 +1578,13 @@ implementation
       end;
 
 
-    function parse_record_method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef;
+    function parse_record_method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef;
       var
         oldparse_only: boolean;
       begin
         oldparse_only:=parse_only;
         parse_only:=true;
-        result:=parse_proc_dec(is_classdef,astruct);
+        result:=parse_proc_dec(is_classdef,astruct,hadgeneric);
 
         { this is for error recovery as well as forward }
         { interface mappings, i.e. mapping to a method  }

compiler/pdecvar.pas

@@ -31,14 +31,14 @@ interface
       symtable,symsym,symdef;
 
     type
-      tvar_dec_option=(vd_record,vd_object,vd_threadvar,vd_class,vd_final,vd_canreorder);
+      tvar_dec_option=(vd_record,vd_object,vd_threadvar,vd_class,vd_final,vd_canreorder,vd_check_generic);
       tvar_dec_options=set of tvar_dec_option;
 
     function  read_property_dec(is_classproperty:boolean;astruct:tabstractrecorddef):tpropertysym;
 
-    procedure read_var_decls(options:Tvar_dec_options);
+    procedure read_var_decls(options:Tvar_dec_options;out had_generic:boolean);
 
-    procedure read_record_fields(options:Tvar_dec_options; reorderlist: TFPObjectList; variantdesc: ppvariantrecdesc);
+    procedure read_record_fields(options:Tvar_dec_options; reorderlist: TFPObjectList; variantdesc: ppvariantrecdesc;out had_generic:boolean);
 
     procedure read_public_and_external(vs: tabstractvarsym);
 
@@ -1050,7 +1050,7 @@ implementation
     end;
 
 
-    procedure read_var_decls(options:Tvar_dec_options);
+    procedure read_var_decls(options:Tvar_dec_options;out had_generic:boolean);
 
         procedure read_default_value(sc : TFPObjectList);
         var
@@ -1266,6 +1266,8 @@ implementation
          vs   : tabstractvarsym;
          hdef : tdef;
          i    : longint;
+         first,
+         isgeneric,
          semicoloneaten,
          allowdefaultvalue,
          hasdefaultvalue : boolean;
@@ -1273,6 +1275,8 @@ implementation
          deprecatedmsg   : pshortstring;
          old_block_type  : tblock_type;
          sectionname : ansistring;
+         tmp_filepos,
+         old_current_filepos     : tfileposinfo;
       begin
          old_block_type:=block_type;
          block_type:=bt_var;
@@ -1281,6 +1285,8 @@ implementation
            consume(_ID);
          { read vars }
          sc:=TFPObjectList.create(false);
+         first:=true;
+         had_generic:=false;
          while (token=_ID) do
            begin
              semicoloneaten:=false;
@@ -1290,13 +1296,16 @@ implementation
              repeat
                if (token = _ID) then
                  begin
+                   isgeneric:=(vd_check_generic in options) and
+                                not (m_delphi in current_settings.modeswitches) and
+                                (idtoken=_GENERIC);
                    case symtablestack.top.symtabletype of
                      localsymtable :
-                       vs:=clocalvarsym.create(orgpattern,vs_value,generrordef,[],true);
+                       vs:=clocalvarsym.create(orgpattern,vs_value,generrordef,[],false);
                      staticsymtable,
                      globalsymtable :
                        begin
-                         vs:=cstaticvarsym.create(orgpattern,vs_value,generrordef,[],true);
+                         vs:=cstaticvarsym.create(orgpattern,vs_value,generrordef,[],false);
                          if vd_threadvar in options then
                            include(vs.varoptions,vo_is_thread_var);
                        end;
@@ -1304,11 +1313,43 @@ implementation
                        internalerror(200411064);
                    end;
                    sc.add(vs);
+                   if isgeneric then
+                     tmp_filepos:=current_filepos;
+                 end
+               else
+                 isgeneric:=false;
+               consume(_ID);
+               { when the first variable had been read the next declaration could be
+                 a "generic procedure", "generic function" or
+                 "generic class (function/procedure)" }
+               if not first
+                   and isgeneric
+                   and (sc.count=1)
+                   and (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
+                 begin
+                   vs.free;
+                   sc.clear;
+                   had_generic:=true;
+                   break;
+                 end
+               else
+                 begin
+                   vs.register_sym;
                    symtablestack.top.insert(vs);
+                   if isgeneric then
+                     begin
+                       { ensure correct error position }
+                       old_current_filepos:=current_filepos;
+                       current_filepos:=tmp_filepos;
+                       symtablestack.top.insert(vs);
+                       current_filepos:=old_current_filepos;
+                     end;
                  end;
-               consume(_ID);
              until not try_to_consume(_COMMA);
 
+             if had_generic then
+               break;
+
              { read variable type def }
              block_type:=bt_var_type;
              consume(_COLON);
@@ -1445,6 +1486,8 @@ implementation
                     not(vo_is_external in vs.varoptions) then
                    cnodeutils.insertbssdata(tstaticvarsym(vs));
                end;
+
+             first:=false;
            end;
          block_type:=old_block_type;
          { free the list }
@@ -1452,7 +1495,7 @@ implementation
       end;
 
 
-    procedure read_record_fields(options:Tvar_dec_options; reorderlist: TFPObjectList; variantdesc : ppvariantrecdesc);
+    procedure read_record_fields(options:Tvar_dec_options; reorderlist: TFPObjectList; variantdesc : ppvariantrecdesc;out had_generic:boolean);
       var
          sc : TFPObjectList;
          i  : longint;
@@ -1478,6 +1521,7 @@ implementation
          uniondef : trecorddef;
          hintsymoptions : tsymoptions;
          deprecatedmsg : pshortstring;
+         hadgendummy,
          semicoloneaten,
          removeclassoption: boolean;
 {$if defined(powerpc) or defined(powerpc64)}
@@ -1498,6 +1542,7 @@ implementation
          { read vars }
          sc:=TFPObjectList.create(false);
          removeclassoption:=false;
+         had_generic:=false;
          while (token=_ID) and
             not(((vd_object in options) or
                  ((vd_record in options) and (m_advanced_records in current_settings.modeswitches))) and
@@ -1512,22 +1557,39 @@ implementation
                sorg:=orgpattern;
                if token=_ID then
                  begin
-                   vs:=cfieldvarsym.create(sorg,vs_value,generrordef,[],true);
+                   vs:=cfieldvarsym.create(sorg,vs_value,generrordef,[],false);
 
                    { normally the visibility is set via addfield, but sometimes
                      we collect symbols so we can add them in a batch of
                      potentially mixed visibility, and then the individual
                      symbols need to have their visibility already set }
                    vs.visibility:=visibility;
+                   if (vd_check_generic in options) and (idtoken=_GENERIC) then
+                     had_generic:=true;
+                 end
+               else
+                 vs:=nil;
+               consume(_ID);
+               if assigned(vs) and
+                  (
+                    not had_generic or
+                    not (token in [_PROCEDURE,_FUNCTION,_CLASS])
+                  ) then
+                 begin
+                   vs.register_sym;
                    sc.add(vs);
                    recst.insert(vs);
-                 end;
-               consume(_ID);
+                   had_generic:=false;
+                 end
+               else
+                 vs.free;
              until not try_to_consume(_COMMA);
              if m_delphi in current_settings.modeswitches then
                block_type:=bt_var_type
              else
                block_type:=old_block_type;
+             if had_generic and (sc.count=0) then
+               break;
              consume(_COLON);
 
              read_anon_type(hdef,false);
@@ -1802,7 +1864,7 @@ implementation
                 consume(_LKLAMMER);
                 inc(variantrecordlevel);
                 if token<>_RKLAMMER then
-                  read_record_fields([vd_record],nil,@variantdesc^^.branches[high(variantdesc^^.branches)].nestedvariant);
+                  read_record_fields([vd_record],nil,@variantdesc^^.branches[high(variantdesc^^.branches)].nestedvariant,hadgendummy);
                 dec(variantrecordlevel);
                 consume(_RKLAMMER);
 

compiler/psub.pas

@@ -83,7 +83,7 @@ interface
     { reads any routine in the implementation, or a non-method routine
       declaration in the interface (depending on whether or not parse_only is
       true) }
-    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef);
+    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef;isgeneric:boolean);
 
     procedure generate_specialization_procs;
 
@@ -2033,7 +2033,7 @@ implementation
       end;
 
 
-    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef);
+    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef;isgeneric:boolean);
       {
         Parses the procedure directives, then parses the procedure body, then
         generates the code for it
@@ -2062,7 +2062,7 @@ implementation
 
          if not assigned(usefwpd) then
            { parse procedure declaration }
-           pd:=parse_proc_dec(isclassmethod,old_current_structdef)
+           pd:=parse_proc_dec(isclassmethod,old_current_structdef,isgeneric)
          else
            pd:=usefwpd;
 
@@ -2224,24 +2224,52 @@ implementation
 
 
     procedure read_declarations(islibrary : boolean);
+      var
+        hadgeneric : boolean;
+
+        procedure handle_unexpected_had_generic;
+          begin
+            if hadgeneric then
+              begin
+                Message(parser_e_procedure_or_function_expected);
+                hadgeneric:=false;
+              end;
+          end;
+
       var
         is_classdef:boolean;
       begin
         is_classdef:=false;
+        hadgeneric:=false;
         repeat
            if not assigned(current_procinfo) then
              internalerror(200304251);
            case token of
               _LABEL:
-                label_dec;
+                begin
+                  handle_unexpected_had_generic;
+                  label_dec;
+                end;
               _CONST:
-                const_dec;
+                begin
+                  handle_unexpected_had_generic;
+                  const_dec(hadgeneric);
+                end;
               _TYPE:
-                type_dec;
+                begin
+                  handle_unexpected_had_generic;
+                  type_dec(hadgeneric);
+                end;
               _VAR:
-                var_dec;
+                begin
+                  handle_unexpected_had_generic;
+                  var_dec(hadgeneric);
+                end;
               _THREADVAR:
-                threadvar_dec;
+                begin
+                  handle_unexpected_had_generic;
+                  threadvar_dec(hadgeneric);
+                end;
               _CLASS:
                 begin
                   is_classdef:=false;
@@ -2266,11 +2294,18 @@ implementation
               _PROCEDURE,
               _OPERATOR:
                 begin
-                  read_proc(is_classdef,nil);
+                  if hadgeneric and not (token in [_PROCEDURE,_FUNCTION]) then
+                    begin
+                      Message(parser_e_procedure_or_function_expected);
+                      hadgeneric:=false;
+                    end;
+                  read_proc(is_classdef,nil,hadgeneric);
                   is_classdef:=false;
+                  hadgeneric:=false;
                 end;
               _EXPORTS:
                 begin
+                   handle_unexpected_had_generic;
                    if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then
                      begin
                         Message(parser_e_syntax_error);
@@ -2287,6 +2322,7 @@ implementation
                 end;
               _PROPERTY:
                 begin
+                  handle_unexpected_had_generic;
                   if (m_fpc in current_settings.modeswitches) then
                     property_dec
                   else
@@ -2297,23 +2333,36 @@ implementation
                   case idtoken of
                     _RESOURCESTRING:
                       begin
+                        handle_unexpected_had_generic;
                         { m_class is needed, because the resourcestring
                           loading is in the ObjPas unit }
 {                        if (m_class in current_settings.modeswitches) then}
-                          resourcestring_dec
+                          resourcestring_dec(hadgeneric)
 {                        else
                           break;}
                       end;
                     _OPERATOR:
                       begin
+                        handle_unexpected_had_generic;
                         if is_classdef then
                           begin
-                            read_proc(is_classdef,nil);
+                            read_proc(is_classdef,nil,false);
                             is_classdef:=false;
                           end
                         else
                           break;
                       end;
+                    _GENERIC:
+                      begin
+                        handle_unexpected_had_generic;
+                        if not (m_delphi in current_settings.modeswitches) then
+                          begin
+                            consume(_ID);
+                            hadgeneric:=true;
+                          end
+                        else
+                          break;
+                      end
                     else
                       break;
                   end;
@@ -2335,33 +2384,81 @@ implementation
 
 
     procedure read_interface_declarations;
+      var
+        hadgeneric : boolean;
+
+        procedure handle_unexpected_had_generic;
+          begin
+            if hadgeneric then
+              begin
+                Message(parser_e_procedure_or_function_expected);
+                hadgeneric:=false;
+              end;
+          end;
+
       begin
+         hadgeneric:=false;
          repeat
            case token of
              _CONST :
-               const_dec;
+               begin
+                 handle_unexpected_had_generic;
+                 const_dec(hadgeneric);
+               end;
              _TYPE :
-               type_dec;
+               begin
+                 handle_unexpected_had_generic;
+                 type_dec(hadgeneric);
+               end;
              _VAR :
-               var_dec;
+               begin
+                 handle_unexpected_had_generic;
+                 var_dec(hadgeneric);
+               end;
              _THREADVAR :
-               threadvar_dec;
+               begin
+                 handle_unexpected_had_generic;
+                 threadvar_dec(hadgeneric);
+               end;
              _FUNCTION,
              _PROCEDURE,
              _OPERATOR :
-               read_proc(false,nil);
+               begin
+                 if hadgeneric and not (token in [_FUNCTION, _PROCEDURE]) then
+                   begin
+                     message(parser_e_procedure_or_function_expected);
+                     hadgeneric:=false;
+                   end;
+                 read_proc(false,nil,hadgeneric);
+                 hadgeneric:=false;
+               end;
              else
                begin
                  case idtoken of
                    _RESOURCESTRING :
-                     resourcestring_dec;
+                     begin
+                       handle_unexpected_had_generic;
+                       resourcestring_dec(hadgeneric);
+                     end;
                    _PROPERTY:
                      begin
+                       handle_unexpected_had_generic;
                        if (m_fpc in current_settings.modeswitches) then
                          property_dec
                        else
                          break;
                      end;
+                   _GENERIC:
+                     begin
+                       handle_unexpected_had_generic;
+                       if not (m_delphi in current_settings.modeswitches) then
+                         begin
+                           hadgeneric:=true;
+                           consume(_ID);
+                         end
+                       else
+                         break;
+                     end
                    else
                      break;
                  end;

compiler/ptype.pas

@@ -654,6 +654,7 @@ implementation
         pd : tprocdef;
         oldparse_only: boolean;
         member_blocktype : tblock_type;
+        hadgeneric,
         fields_allowed, is_classdef, classfields: boolean;
         vdoptions: tvar_dec_options;
       begin
@@ -672,6 +673,7 @@ implementation
         current_structdef.symtable.currentvisibility:=vis_public;
         fields_allowed:=true;
         is_classdef:=false;
+        hadgeneric:=false;
         classfields:=false;
         member_blocktype:=bt_general;
         repeat
@@ -779,7 +781,7 @@ implementation
                     else
                     if is_classdef and (idtoken=_OPERATOR) then
                       begin
-                        pd:=parse_record_method_dec(current_structdef,is_classdef);
+                        pd:=parse_record_method_dec(current_structdef,is_classdef,false);
                         fields_allowed:=false;
                         is_classdef:=false;
                       end
@@ -787,17 +789,33 @@ implementation
                       begin
                         if member_blocktype=bt_general then
                           begin
-                            if (not fields_allowed)and(idtoken<>_CASE) then
-                              Message(parser_e_field_not_allowed_here);
-                            vdoptions:=[vd_record];
-                            if classfields then
-                              include(vdoptions,vd_class);
-                            read_record_fields(vdoptions,nil,nil);
+                            if (idtoken=_GENERIC) and
+                                not (m_delphi in current_settings.modeswitches) and
+                                not fields_allowed then
+                              begin
+                                if hadgeneric then
+                                  Message(parser_e_procedure_or_function_expected);
+                                consume(_ID);
+                                hadgeneric:=true;
+                                if not (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
+                                  Message(parser_e_procedure_or_function_expected);
+                              end
+                            else
+                              begin
+                                if (not fields_allowed)and(idtoken<>_CASE) then
+                                  Message(parser_e_field_not_allowed_here);
+                                vdoptions:=[vd_record];
+                                if classfields then
+                                  include(vdoptions,vd_class);
+                                if not (m_delphi in current_settings.modeswitches) then
+                                  include(vdoptions,vd_check_generic);
+                                read_record_fields(vdoptions,nil,nil,hadgeneric);
+                              end;
                           end
                         else if member_blocktype=bt_type then
-                          types_dec(true)
+                          types_dec(true,hadgeneric)
                         else if member_blocktype=bt_const then
-                          consts_dec(true,true)
+                          consts_dec(true,true,hadgeneric)
                         else
                           internalerror(201001110);
                       end;
@@ -818,8 +836,9 @@ implementation
                 consume(_CLASS);
                 { class modifier is only allowed for procedures, functions, }
                 { constructors, destructors, fields and properties          }
-                if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and
-                   not((token=_ID) and (idtoken=_OPERATOR)) then
+                if (hadgeneric and not (token in [_FUNCTION,_PROCEDURE])) or
+                    (not hadgeneric and (not (token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and
+                   not((token=_ID) and (idtoken=_OPERATOR)))) then
                   Message(parser_e_procedure_or_function_expected);
 
                 if IsAnonOrLocal then
@@ -832,7 +851,8 @@ implementation
               begin
                 if IsAnonOrLocal then
                   Message(parser_e_no_methods_in_local_anonymous_records);
-                pd:=parse_record_method_dec(current_structdef,is_classdef);
+                pd:=parse_record_method_dec(current_structdef,is_classdef,hadgeneric);
+                hadgeneric:=false;
                 fields_allowed:=false;
                 is_classdef:=false;
               end;
@@ -909,6 +929,7 @@ implementation
          old_current_specializedef: tstoreddef;
          old_parse_generic: boolean;
          recst: trecordsymtable;
+         hadgendummy : boolean;
       begin
          old_current_structdef:=current_structdef;
          old_current_genericdef:=current_genericdef;
@@ -971,7 +992,7 @@ implementation
            end
          else
            begin
-             read_record_fields([vd_record],nil,nil);
+             read_record_fields([vd_record],nil,nil,hadgendummy);
 {$ifdef jvm}
              { we need a constructor to create temps, a deep copy helper, ... }
              add_java_default_record_methods_intf(trecorddef(current_structdef));

compiler/symcreat.pas

@@ -207,9 +207,9 @@ implementation
           pd:=destructor_head;
         else if assigned(astruct) and
            (astruct.typ=recorddef) then
-          pd:=parse_record_method_dec(astruct,is_classdef)
+          pd:=parse_record_method_dec(astruct,is_classdef,false)
         else
-          pd:=method_dec(astruct,is_classdef);
+          pd:=method_dec(astruct,is_classdef,false);
       end;
       if assigned(pd) then
         result:=true;
@@ -247,7 +247,7 @@ implementation
       current_scanner.substitutemacro('meth_impl_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index);
       current_scanner.readtoken(false);
       { and parse it... }
-      read_proc(is_classdef,usefwpd);
+      read_proc(is_classdef,usefwpd,false);
       parse_only:=oldparse_only;
       { remove the temporary macro input file again }
       current_scanner.closeinputfile;