Fix compilation of unit "fgl.pp" and of test "tests/test/tgeneric29.pp".

symtable.pas:
  * reduce the "childdef" parameter of "is_owned_by" from "tabstractrecorddef" to "tdef", so that more primitive defs can be checked as well
  * add a new function "sym_is_owned_by" which is similar to "is_owned_by", but takes a symbol and a symtable as parameter; the owner chain of the symtable is checked until a non-object- and non-record-symtable is reached

ptype.pas:
  * extend "id_type", so that the symbol and the symtable that belongs to the returned def is returned as well
  * this is needed to check inside "single_type" whether a def that is a generic was specialized inside another generic, because in that case the genericdef is returned by "generate_specialization" and not a new specialized def, but the corresponding type symbol (which is different from "hdef.typesym") belongs to the class itself; I need to admit that this solution isn't very clean and one could try to circumvent some of the checks, so I need to find a better detection for such a case (concrete example: the enumerator specialization inside the classes of "fgl.pas")
  * in "read_named_type.expr_type" the check for "df_generic" is extended analogous to the previous change, but instead of relying on the symbol it uses the def. This is needed so that types like method pointers that are defined inside the current generic are not disallowed as they contain the "df_generic" flag as well; like the previous change this change isn't clean either and maybe it's better to remove the inclusion of the "df_generic" flag from everything except records and "objects" inside records/"objects" again. Such a solution will "only" reduce the problem to records and "objects" though...

pgenutil.pas:
  * only add a new undefined def if we're not parsing the parent class or interfaces ("parse_class_parent" is true), otherwise the InternalError regarding the "equal count of defs" will trigger
  * there are now two cases where we need to return a generic def instead of a undefined one when we're parsing a generic:
    a) we have the previously mentioned case that "parse_class_parent" is true
    b) an undefined def was added, but we need to return a generic def, so that checks can be passed
  * use the correct variable when building the generic name, otherwise we get errors like "identifier '$1' not found"
  * don't push the symtable if we're currently parsing the list of interfaces or the parent class, because then e.g. a generic interface will be included in the symtable of the implementing class which isn't what we want; the current solution is not clean though, so this needs to be investigated more
  * Note: In the current state of "generate_specialization" the function could be simplyfied a bit more; this will be done when the implementation is satisfactory enough

git-svn-id: branches/svenbarth/generics@19430 -

compiler/pgenutil.pas

@@ -94,12 +94,12 @@ uses
         { only need to record the tokens, then we don't know the type yet  ... }
         if parse_generic then
           begin
-            { ... but we have to insert a def into the symtable else the deflist
+            { ... but we have to insert a def into the symtable if the generic
+              is not a parent or an implemented interface else the deflist
               of generic and specialization might not be equally sized which
               is later assumed }
-            tt:=tundefineddef.create;
-            if parse_class_parent then
-              tt:=genericdef;
+            if not parse_class_parent then
+              tt:=tundefineddef.create;
             onlyparsepara:=true;
           end;
 
@@ -115,7 +115,9 @@ uses
               inc(gencount);
             until not try_to_consume(_COMMA);
             consume(_RSHARPBRACKET);
-            if parse_generic and parse_class_parent then
+            { we need to return a def that can later pass some checks like
+              whether it's an interface or not }
+            if parse_generic and (not assigned(tt) or (tt.typ=undefineddef)) then
               begin
                 if (symname='') and (df_generic in genericdef.defoptions) then
                   { this happens in non-Delphi modes }
@@ -129,7 +131,7 @@ uses
                       genname:=ttypesym(genericdef.typesym).realname
                     else
                       genname:=symname;
-                    genname:=symname+'$'+countstr;
+                    genname:=genname+'$'+countstr;
                     ugenname:=upper(genname);
                     if not searchsym(ugenname,srsym,st) or
                         (srsym.typ<>typesym) then
@@ -137,6 +139,8 @@ uses
                         identifier_not_found(genname);
                         exit;
                       end;
+                    if not (ttypesym(srsym).typedef is tstoreddef) then
+                      Internalerror(2011091601);
                     tt:=ttypesym(srsym).typedef;
                   end;
               end;
@@ -315,12 +319,19 @@ uses
             if assigned(hmodule.globalsymtable) then
               symtablestack.push(hmodule.globalsymtable);
 
-            { hacky, but necessary to insert the newly generated class properly }
-            item:=oldsymtablestack.stack;
-            while assigned(item) and (item^.symtable.symtablelevel>main_program_level) do
-              item:=item^.next;
-            if assigned(item) and (item^.symtable<>symtablestack.top) then
-              symtablestack.push(item^.symtable);
+            { in case of a parent or an implemented interface the class needs
+              to be inserted in the current unit and not in the class it's
+              used in }
+            { TODO: check whether we are using the correct symtable }
+            if not parse_class_parent then
+              begin
+                { hacky, but necessary to insert the newly generated class properly }
+                item:=oldsymtablestack.stack;
+                while assigned(item) and (item^.symtable.symtablelevel>main_program_level) do
+                  item:=item^.next;
+                if assigned(item) and (item^.symtable<>symtablestack.top) then
+                  symtablestack.push(item^.symtable);
+              end;
 
             { Reparse the original type definition }
             if not err then

compiler/ptype.pas

@@ -141,7 +141,7 @@ implementation
       end;
 
 
-    procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean); forward;
+    procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean;out srsym:tsym;out srsymtable:tsymtable); forward;
 
     { def is the outermost type in which other types have to be searched
 
@@ -157,6 +157,8 @@ implementation
       var
         t2: tdef;
         structstackindex: longint;
+        srsym: tsym;
+        srsymtable: tsymtable;
       begin
         if assigned(currentstructstack) then
           structstackindex:=currentstructstack.count-1
@@ -185,7 +187,7 @@ implementation
                      structstackindex:=-1;
                      symtablestack.push(tabstractrecorddef(def).symtable);
                      t2:=generrordef;
-                     id_type(t2,isforwarddef,false,false);
+                     id_type(t2,isforwarddef,false,false,srsym,srsymtable);
                      symtablestack.pop(tabstractrecorddef(def).symtable);
                      def:=t2;
                    end;
@@ -230,18 +232,18 @@ implementation
          result:=false;
       end;
 
-    procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean);
+    procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean;out srsym:tsym;out srsymtable:tsymtable);
     { reads a type definition }
     { to a appropriating tdef, s gets the name of   }
     { the type to allow name mangling          }
       var
         is_unit_specific : boolean;
         pos : tfileposinfo;
-        srsym : tsym;
-        srsymtable : TSymtable;
         s,sorg : TIDString;
         t : ttoken;
       begin
+         srsym:=nil;
+         srsymtable:=nil;
          s:=pattern;
          sorg:=orgpattern;
          pos:=current_tokenpos;
@@ -308,6 +310,8 @@ implementation
          t2 : tdef;
          dospecialize,
          again : boolean;
+         srsym : tsym;
+         srsymtable : tsymtable;
        begin
          dospecialize:=false;
          repeat
@@ -354,7 +358,7 @@ implementation
                      end
                    else
                      begin
-                       id_type(def,stoIsForwardDef in options,true,true);
+                       id_type(def,stoIsForwardDef in options,true,true,srsym,srsymtable);
                        parse_nested_types(def,stoIsForwardDef in options,nil);
                      end;
                  end;
@@ -381,7 +385,14 @@ implementation
               begin
                 def:=current_genericdef
               end
-            else if (df_generic in def.defoptions) then
+            else if (df_generic in def.defoptions) and
+                not
+                  (
+                    parse_generic and
+                    (current_genericdef.typ in [recorddef,objectdef]) and
+                    sym_is_owned_by(srsym,tabstractrecorddef(current_genericdef).symtable)
+                  )
+                then
               begin
                 Message(parser_e_no_generics_as_types);
                 def:=generrordef;
@@ -853,7 +864,14 @@ implementation
                          begin
                            def:=current_genericdef
                          end
-                       else if (df_generic in def.defoptions) then
+                       else if (df_generic in def.defoptions) and
+                           not
+                             (
+                               parse_generic and
+                               (current_genericdef.typ in [recorddef,objectdef]) and
+                               is_owned_by(def,tabstractrecorddef(current_genericdef))
+                             )
+                           then
                          begin
                            Message(parser_e_no_generics_as_types);
                            def:=generrordef;

compiler/symtable.pas

@@ -213,7 +213,8 @@ interface
 
 {*** Search ***}
     procedure addsymref(sym:tsym);
-    function  is_owned_by(childdef,ownerdef:tabstractrecorddef):boolean;
+    function  is_owned_by(childdef:tdef;ownerdef:tabstractrecorddef):boolean;
+    function  sym_is_owned_by(childsym:tsym;symtable:tsymtable):boolean;
     function  is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
     function  is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
     function  is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
@@ -1805,13 +1806,20 @@ implementation
        end;
 
 
-    function is_owned_by(childdef,ownerdef:tabstractrecorddef):boolean;
+    function is_owned_by(childdef:tdef;ownerdef:tabstractrecorddef):boolean;
       begin
         result:=childdef=ownerdef;
         if not result and (childdef.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
           result:=is_owned_by(tabstractrecorddef(childdef.owner.defowner),ownerdef);
       end;
 
+    function sym_is_owned_by(childsym:tsym;symtable:tsymtable):boolean;
+      begin
+        result:=childsym.owner=symtable;
+        if not result and (childsym.owner.symtabletype in [objectsymtable,recordsymtable]) then
+          result:=sym_is_owned_by(tabstractrecorddef(childsym.owner.defowner).typesym,symtable);
+      end;
+
     function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
       var
         symownerdef : tabstractrecorddef;