compiler: implement generic procedural types

  - store type parameter in parasymtable, push it to the symtablestack before parsing arguments and return type
  - move procedure/function declaration parsing to procvar_dec subroutine
  - don't skip parasymtable while searching types because they store type parameters now
  - add TParaSymTable.ReadOnly field to prevent adding defs into symtable. Add defs to the parent symtable in this case (we are adding this symtable to stack to read type parameters only, add defs should go to parent in this case as it was before)

git-svn-id: trunk@16719 -

.gitattributes

@@ -9426,6 +9426,7 @@ tests/test/tgeneric3.pp svneol=native#text/plain
 tests/test/tgeneric30.pp svneol=native#text/pascal
 tests/test/tgeneric31.pp svneol=native#text/pascal
 tests/test/tgeneric32.pp svneol=native#text/pascal
+tests/test/tgeneric33.pp svneol=native#text/pascal
 tests/test/tgeneric4.pp svneol=native#text/plain
 tests/test/tgeneric5.pp svneol=native#text/plain
 tests/test/tgeneric6.pp svneol=native#text/plain

compiler/pdecl.pas

@@ -611,7 +611,7 @@ implementation
               end;
             end;
 
-           if isgeneric and not(hdef.typ in [objectdef,recorddef,arraydef]) then
+           if isgeneric and not(hdef.typ in [objectdef,recorddef,arraydef,procvardef]) then
              message(parser_e_cant_create_generics_of_this_type);
 
            { Stop recording a generic template }

compiler/pdecobj.pas

@@ -602,6 +602,7 @@ implementation
         case def.typ of
           recorddef,objectdef: st:=tabstractrecorddef(def).symtable;
           arraydef: st:=tarraydef(def).symtable;
+          procvardef: st:=tprocvardef(def).parast;
           else
             internalerror(201101020);
         end;

compiler/ptype.pas

@@ -215,6 +215,8 @@ implementation
             st:=genericdef.GetSymtable(gs_record);
           arraydef:
             st:=tarraydef(genericdef).symtable;
+          procvardef:
+            st:=genericdef.GetSymtable(gs_para);
           else
             internalerror(200511182);
         end;
@@ -327,17 +329,31 @@ implementation
                 read_named_type(tt,specializename,genericdef,generictypelist,false);
                 ttypesym(srsym).typedef:=tt;
                 tt.typesym:=srsym;
+
+                case tt.typ of
+                  { Build VMT indexes for classes }
+                  objectdef:
+                    begin
+                      vmtbuilder:=TVMTBuilder.Create(tobjectdef(tt));
+                      vmtbuilder.generate_vmt;
+                      vmtbuilder.free;
+                    end;
+                  { handle params, calling convention, etc }
+                  procvardef:
+                    begin
+                      if not check_proc_directive(true) then
+                        begin
+                          try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
+                          consume(_SEMICOLON);
+                        end;
+                      parse_var_proc_directives(ttypesym(srsym));
+                      handle_calling_convention(tprocvardef(tt));
+                      if try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg) then
+                        consume(_SEMICOLON);
+                    end;
+                end;
                 { Consume the semicolon if it is also recorded }
                 try_to_consume(_SEMICOLON);
-
-
-                { Build VMT indexes for classes }
-                if (tt.typ=objectdef) then
-                  begin
-                    vmtbuilder:=TVMTBuilder.Create(tobjectdef(tt));
-                    vmtbuilder.generate_vmt;
-                    vmtbuilder.free;
-                  end;
               end;
 
             { Restore symtablestack }
@@ -1247,15 +1263,87 @@ implementation
            current_genericdef:=old_current_genericdef;
            current_specializedef:=old_current_specializedef;
         end;
+
+        function procvar_dec(genericdef:tstoreddef;genericlist:TFPObjectList):tdef;
+          var
+            is_func:boolean;
+            pd:tabstractprocdef;
+            newtype:ttypesym;
+            old_current_genericdef,
+            old_current_specializedef: tstoreddef;
+            old_parse_generic: boolean;
+          begin
+            old_current_genericdef:=current_genericdef;
+            old_current_specializedef:=current_specializedef;
+            old_parse_generic:=parse_generic;
+
+            current_genericdef:=nil;
+            current_specializedef:=nil;
+
+            is_func:=(token=_FUNCTION);
+            consume(token);
+            pd:=tprocvardef.create(normal_function_level);
+
+            { usage of specialized type inside its generic template }
+            if assigned(genericdef) then
+              current_specializedef:=pd
+            { reject declaration of generic class inside generic class }
+            else if assigned(genericlist) then
+              current_genericdef:=pd;
+            symtablestack.push(pd.parast);
+            insert_generic_parameter_types(pd,genericdef,genericlist);
+            parse_generic:=(df_generic in pd.defoptions);
+            { don't allow to add defs to the symtable - use it for type param search only }
+            tparasymtable(pd.parast).readonly:=true;
+
+            if token=_LKLAMMER then
+              parse_parameter_dec(pd);
+            if is_func then
+              begin
+                consume(_COLON);
+                single_type(pd.returndef,[]);
+              end;
+            if try_to_consume(_OF) then
+              begin
+                consume(_OBJECT);
+                include(pd.procoptions,po_methodpointer);
+              end
+            else if (m_nested_procvars in current_settings.modeswitches) and
+                    try_to_consume(_IS) then
+              begin
+                consume(_NESTED);
+                pd.parast.symtablelevel:=normal_function_level+1;
+                pd.check_mark_as_nested;
+              end;
+            symtablestack.pop(pd.parast);
+            tparasymtable(pd.parast).readonly:=false;
+            result:=pd;
+            { possible proc directives }
+            if parseprocvardir then
+              begin
+                if check_proc_directive(true) then
+                  begin
+                    newtype:=ttypesym.create('unnamed',result);
+                    parse_var_proc_directives(tsym(newtype));
+                    newtype.typedef:=nil;
+                    result.typesym:=nil;
+                    newtype.free;
+                  end;
+                { Add implicit hidden parameters and function result }
+                handle_calling_convention(pd);
+              end;
+            { restore old state }
+            parse_generic:=old_parse_generic;
+            current_genericdef:=old_current_genericdef;
+            current_specializedef:=old_current_specializedef;
+          end;
+
       const
         SingleTypeOptionsInTypeBlock:array[Boolean] of TSingleTypeOptions = ([],[stoIsForwardDef]);
       var
         p  : tnode;
         hdef : tdef;
-        pd : tabstractprocdef;
-        is_func,
         enumdupmsg, first, is_specialize : boolean;
-        newtype : ttypesym;
         oldlocalswitches : tlocalswitches;
         bitpacking: boolean;
         stitem: psymtablestackitem;
@@ -1506,43 +1594,7 @@ implementation
             _PROCEDURE,
             _FUNCTION:
               begin
-                is_func:=(token=_FUNCTION);
-                consume(token);
-                pd:=tprocvardef.create(normal_function_level);
-                if token=_LKLAMMER then
-                  parse_parameter_dec(pd);
-                if is_func then
-                 begin
-                   consume(_COLON);
-                   single_type(pd.returndef,[]);
-                 end;
-                if try_to_consume(_OF) then
-                  begin
-                    consume(_OBJECT);
-                    include(pd.procoptions,po_methodpointer);
-                  end
-                else if (m_nested_procvars in current_settings.modeswitches) and
-                        try_to_consume(_IS) then
-                  begin
-                    consume(_NESTED);
-                    pd.parast.symtablelevel:=normal_function_level+1;
-                    pd.check_mark_as_nested;
-                  end;
-                def:=pd;
-                { possible proc directives }
-                if parseprocvardir then
-                  begin
-                    if check_proc_directive(true) then
-                      begin
-                         newtype:=ttypesym.create('unnamed',def);
-                         parse_var_proc_directives(tsym(newtype));
-                         newtype.typedef:=nil;
-                         def.typesym:=nil;
-                         newtype.free;
-                      end;
-                    { Add implicit hidden parameters and function result }
-                    handle_calling_convention(pd);
-                  end;
+                def:=procvar_dec(genericdef,genericlist);
               end;
             else
               if (token=_KLAMMERAFFE) and (m_iso in current_settings.modeswitches) then

compiler/symtable.pas

@@ -125,13 +125,17 @@ interface
        tlocalsymtable = class(tabstractlocalsymtable)
        public
           constructor create(adefowner:tdef;level:byte);
-          function  checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
+          function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
        end;
 
+       { tparasymtable }
+
        tparasymtable = class(tabstractlocalsymtable)
        public
+          readonly: boolean;
           constructor create(adefowner:tdef;level:byte);
-          function  checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
+          function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
+          procedure insertdef(def:TDefEntry);override;
        end;
 
        tabstractuniTSymtable = class(tstoredsymtable)
@@ -1373,6 +1377,7 @@ implementation
     constructor tparasymtable.create(adefowner:tdef;level:byte);
       begin
         inherited create('');
+        readonly:=false;
         defowner:=adefowner;
         symtabletype:=parasymtable;
         symtablelevel:=level;
@@ -1395,6 +1400,14 @@ implementation
           result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym);
       end;
 
+    procedure tparasymtable.insertdef(def: TDefEntry);
+      begin
+        if readonly then
+          defowner.owner.insertdef(def)
+        else
+          inherited insertdef(def);
+      end;
+
 
 {****************************************************************************
                          TAbstractUniTSymtable
@@ -1952,11 +1965,11 @@ implementation
                 while assigned(classh) do
                   begin
                     srsymtable:=classh.symtable;
-                srsym:=tsym(srsymtable.FindWithHash(hashedid));
-                if assigned(srsym) and
-                       not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and
-                       is_visible_for_object(srsym,current_structdef) then
-                  begin
+                    srsym:=tsym(srsymtable.FindWithHash(hashedid));
+                     if assigned(srsym) and
+                        not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and
+                        is_visible_for_object(srsym,current_structdef) then
+                       begin
                         addsymref(srsym);
                         result:=true;
                         exit;
@@ -1965,7 +1978,6 @@ implementation
                   end;
               end
             else
-            if srsymtable.symtabletype<>parasymtable then
               begin
                 srsym:=tsym(srsymtable.FindWithHash(hashedid));
                 if assigned(srsym) and 

tests/test/tgeneric33.pp

@@ -0,0 +1,37 @@
+program tgeneric33;
+
+{$mode objfpc}{$H+}
+type
+  // regular procdef
+  generic TProc1<T> = function(Value: T): T;
+  // object procdef
+  generic TProc2<T> = function(Value: T): T of object;
+
+  TFoo = class
+    function Test2(Value: Integer): Integer;
+  end;
+
+function Test1(Value: Integer): Integer;
+begin
+  Result := Value + 1;
+end;
+
+function TFoo.Test2(Value: Integer): Integer;
+begin
+  Result := Value - 1;
+end;
+
+var
+  Foo: TFoo;
+  Proc1: specialize TProc1<Integer>;
+  Proc2: specialize TProc2<Integer>;
+begin
+  Proc1 := @Test1;
+  if Proc1(1) <> 2 then
+    halt(1);
+  Foo := TFoo.Create;
+  Proc2 := @Foo.Test2;
+  if Proc2(2) <> 1 then
+    halt(2);
+  Foo.Free;
+end.