View Issue Details

IDProjectCategoryView StatusLast Update
0034128FPCCompilerpublic2019-08-15 14:03
ReporterSvetozar BelicAssigned To 
PrioritynormalSeverityminorReproducibilityalways
Status acknowledgedResolutionopen 
Product VersionProduct Build 
Target VersionFixed in Version 
Summary0034128: Support for forward declarations of generic types
DescriptionThe compiler currently does not support forward declarations of generic types such as:
TTest<T> = class; // <- Not allowed.

TTest<T> = class
end;

The attached patch file adds support for such declarations.
Additional InformationWhen a type section is parsed and a forward declaration of a generic type is encountered, a symbol and a definition (with oo_is_forward) is created as usual. Because it has oo_is_forward, this definition is incomplete.
Types which use the incomplete definition will add them self to its used_by list.
At the end of the type section (when the generic type is now parsed), resolve_forward_generic_types is called which goes through all the incomplete forward declarations, generates a specialization and replaces the incomplete definitions (by going through the incomplete definition's used_by list).
After it has been replaced, the incomplete definition is deleted.

If this is a wrong way to go about it, I would be happy if someone could provide some pointers to help me implement this a better way.
Tagsgenerics
Fixed in Revision
FPCOldBugId
FPCTarget-
Attached Files
  • 0001-Added-support-for-forward-declarations-of-generic-ty.patch (20,155 bytes)
    From 1bb999c9a649728e2f70de96a59c37c90a57641d Mon Sep 17 00:00:00 2001
    From: Svetozar Belic <toza.belic@gmail.com>
    Date: Fri, 10 Aug 2018 19:26:24 +0200
    Subject: [PATCH] Added support for forward declarations of generic types.
    
    ---
     compiler/pdecl.pas    |  19 ++++++--
     compiler/pdecobj.pas  |   7 +++
     compiler/pdecsub.pas  |   2 +-
     compiler/pdecvar.pas  |   9 +++-
     compiler/pgenutil.pas |  93 +++++++++++++++++++++++++++++++++++--
     compiler/ptype.pas    | 124 +++++++++++++++++++++++++++++++++++++++++++++++++-
     compiler/symtype.pas  |   8 ++++
     7 files changed, 253 insertions(+), 9 deletions(-)
    
    diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas
    index c5b5bcc921..bc07d08ed4 100644
    --- a/compiler/pdecl.pas
    +++ b/compiler/pdecl.pas
    @@ -566,6 +566,11 @@ implementation
                         is_implicit_pointer_object_type(ttypesym(sym).typedef) and
                         (oo_is_forward in tobjectdef(ttypesym(sym).typedef).objectoptions) then
                       begin
    +                    if assigned(generictypelist) and assigned(tobjectdef(ttypesym(sym).typedef).genericparas) then
    +                      { check if generic parameters match the forward declaration }
    +                      if not compare_generic_parameters(generictypelist, tobjectdef(ttypesym(sym).typedef).genericparas) then
    +                        Message1(type_e_generic_declaration_does_not_match, ttypesym(sym).prettyname);
    +
                         case token of
                           _CLASS :
                             objecttype:=default_class_type;
    @@ -680,6 +685,7 @@ implementation
                         begin
                           istyperenaming:=true;
                           include(newtype.symoptions,sp_explicitrename);
    +                      maybe_add_used_by(hdef, newtype);
                         end;
                       if isunique then
                         begin
    @@ -690,9 +696,13 @@ implementation
                           if is_object(hdef) or
                              is_class_or_interface_or_dispinterface(hdef) then
                             begin
    -                          { just create a child class type; this is
    -                            Delphi-compatible }
    -                          hdef:=cobjectdef.create(tobjectdef(hdef).objecttype,genorgtypename,tobjectdef(hdef),true);
    +                          if oo_is_forward in tobjectdef(hdef).objectoptions then
    +                            { Forward declarations are not allowed. }
    +                            Message1(parser_e_forward_declaration_must_be_resolved, hdef.typesymbolprettyname)
    +                          else
    +                            { just create a child class type; this is
    +                              Delphi-compatible }
    +                            hdef:=cobjectdef.create(tobjectdef(hdef).objecttype,genorgtypename,tobjectdef(hdef),true);
                             end
                           else
                             begin
    @@ -946,6 +956,9 @@ implementation
                     ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
                      ((m_final_fields in current_settings.modeswitches) and
                       (idtoken=_FINAL))));
    +
    +         resolve_forward_generic_types;
    +
              { resolve type block forward declarations and restore a unit
                container for them }
              resolve_forward_types;
    diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas
    index 1e41f98a70..c116215f64 100644
    --- a/compiler/pdecobj.pas
    +++ b/compiler/pdecobj.pas
    @@ -1499,6 +1499,13 @@ implementation
                 { add to the list of definitions to check that the forward
                   is resolved. this is required for delphi mode }
                 current_module.checkforwarddefs.add(current_structdef);
    +
    +            { generic parameter types were registered globaly, remove them }
    +            symtablestack.push(current_structdef.symtable);
    +            update_generic_para_ownership(current_structdef,genericdef,genericlist);
    +            symtablestack.pop(current_structdef.symtable);
    +            current_structdef.genericdef := genericdef;
    +
               end
             else
               begin
    diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas
    index e2b0c1712a..487a6f80c1 100644
    --- a/compiler/pdecsub.pas
    +++ b/compiler/pdecsub.pas
    @@ -536,7 +536,7 @@ implementation
                   { update varsym }
                   vs.vardef:=hdef;
                   vs.defaultconstsym:=defaultvalue;
    -
    +              maybe_add_used_by(hdef, vs);
                   if (target_info.system in [system_powerpc_morphos,system_m68k_amiga]) then
                     begin
                       if locationstr<>'' then
    diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas
    index 4d39397e46..97746d1c07 100644
    --- a/compiler/pdecvar.pas
    +++ b/compiler/pdecvar.pas
    @@ -448,7 +448,7 @@ implementation
                begin
                   consume(_COLON);
                   single_type(p.propdef,[stoAllowSpecialization]);
    -
    +              maybe_add_used_by(p.propdef, p);
                   if is_dispinterface(astruct) and not is_automatable(p.propdef) then
                     Message1(type_e_not_automatable,p.propdef.typename);
     
    @@ -1558,6 +1558,7 @@ implementation
              fieldvs   : tfieldvarsym;
              hstaticvs : tstaticvarsym;
              vs    : tabstractvarsym;
    +         absvs : tabsolutevarsym;
              srsym : tsym;
              srsymtable : TSymtable;
              visibility : tvisibility;
    @@ -1730,6 +1731,7 @@ implementation
                    begin
                      fieldvs:=tfieldvarsym(sc[i]);
                      fieldvs.vardef:=hdef;
    +                 maybe_add_used_by(hdef, fieldvs);
                      { insert any additional hint directives }
                      fieldvs.symoptions := fieldvs.symoptions + hintsymoptions;
                      if deprecatedmsg<>nil then
    @@ -1794,6 +1796,11 @@ implementation
                            cnodeutils.insertbssdata(hstaticvs);
                          if vd_final in options then
                            hstaticvs.varspez:=vs_final;
    +                     maybe_add_used_by(hdef, hstaticvs);
    +                     { hstaticvs has generated an absvarsym, add it to used by as well }
    +                     absvs := tabsolutevarsym(recst.Find(lower(generate_nested_name(recst,'_'))+'_'+fieldvs.name));
    +                     if Assigned(absvs) then
    +                       maybe_add_used_by(hdef, absvs);
                        end;
                      if removeclassoption then
                        begin
    diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas
    index 7760a4e134..d423fedb3f 100644
    --- a/compiler/pgenutil.pas
    +++ b/compiler/pgenutil.pas
    @@ -43,9 +43,11 @@ uses
         function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef;
         function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;_prettyname:ansistring):tdef;
         function check_generic_constraints(genericdef:tstoreddef;paradeflist:tfpobjectlist;poslist:tfplist):boolean;
    +    function compare_generic_parameters(deflist1, deflist2 : tfphashobjectlist): boolean;
         function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
         function parse_generic_specialization_types(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean;
         procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
    +    procedure update_generic_para_ownership(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
         procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
         function generate_generic_name(const name:tidstring;specializename:ansistring;owner_hierarchy:string):tidstring;
         procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint);
    @@ -299,6 +301,34 @@ uses
               end;
           end;
     
    +    function compare_generic_parameters(deflist1, deflist2 : tfphashobjectlist):boolean;
    +      var
    +        i : integer;
    +        ts1, ts2 : ttypesym;
    +      begin
    +        if deflist1.count<>deflist2.count then
    +          internalerror(2018081091);
    +
    +        for i:=0 to deflist1.count-1 do
    +          begin
    +            ts1 := ttypesym(deflist1[i]);
    +            ts2 := ttypesym(deflist2[i]);
    +            if (ts1.typedef.typ<>ts2.typedef.typ) or (lower(ts1.realname)<>lower(ts2.Name)) then
    +              exit(false);
    +
    +            if (ts1.typedef.typ = errordef) or (ts2.typedef.typ = errordef) or
    +                (not assigned(tstoreddef(ts1.typedef).genconstraintdata)) then
    +              continue;
    +
    +            if tstoreddef(ts1.typedef).genconstraintdata.flags <> tstoreddef(ts2.typedef).genconstraintdata.flags then
    +              exit(false);
    +
    +            if gcf_class in tstoreddef(ts1.typedef).genconstraintdata.flags then
    +              if tobjectdef(ts1.typedef).childof <> tobjectdef(ts2.typedef).childof then
    +                exit(false);
    +          end;
    +        result := true;
    +      end;
     
         function parse_generic_specialization_types_internal(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean;
           var
    @@ -1056,9 +1086,13 @@ uses
                                 consume(_SEMICOLON);
                             end;
     
    -                      vmtbuilder:=TVMTBuilder.Create(tobjectdef(result));
    -                      vmtbuilder.generate_vmt;
    -                      vmtbuilder.free;
    +                      { Do not build VMT for forward declarations, it will be built later when fully defined. }
    +                      if not (oo_is_forward in tobjectdef(result).objectoptions) then
    +                        begin
    +                          vmtbuilder:=TVMTBuilder.Create(tobjectdef(result));
    +                          vmtbuilder.generate_vmt;
    +                          vmtbuilder.free;
    +                        end;
                         end;
                       { handle params, calling convention, etc }
                       procvardef:
    @@ -1384,6 +1418,7 @@ uses
             i : longint;
             generictype,sym : ttypesym;
             st : tsymtable;
    +        hid : THashedIDString;
           begin
             def.genericdef:=genericdef;
             if not assigned(genericlist) then
    @@ -1418,6 +1453,25 @@ uses
                   end
                 else
                   begin
    +                { check if the parameter sym/def was already created by a forward definition }
    +                if generictype.realname[1]='$' then
    +                  hid.id:=Copy(generictype.realname,2,255)
    +                else
    +                  hid.id:=Upper(generictype.realname);
    +                if st.FindWithHash(hid) <> nil then
    +                  begin
    +                    { delete the typedef if defined, it will not be used }
    +                    if (generictype.typedef<>cundefinedtype) and
    +                       (assigned(generictype.typedef.owner)) then
    +                         generictype.typedef.owner.deletedef(generictype.typedef);
    +                    { delete the symbol as well }
    +                    if assigned(generictype.owner) then
    +                      generictype.owner.Delete(generictype)
    +                    else
    +                      generictype.free;
    +                    continue;
    +                  end;
    +
                     if (generictype.typedef.typ=undefineddef) and (generictype.typedef<>cundefinedtype) then
                       begin
                         { the generic parameters were parsed before the genericdef existed thus the
    @@ -1433,6 +1487,39 @@ uses
               end;
            end;
     
    +    procedure update_generic_para_ownership(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
    +      var
    +        i : longint;
    +        generictype,sym : ttypesym;
    +        st : tsymtable;
    +      begin
    +        if not assigned(genericlist) or (genericlist.count<1) or (def.typ<>objectdef) then
    +          exit;
    +
    +        st:=tobjectdef(def).symtable;
    +
    +        if not assigned(def.genericparas) then
    +          def.genericparas:=tfphashobjectlist.create(false);
    +        for i:=0 to genericlist.count-1 do
    +          begin
    +            generictype:=ttypesym(genericlist[i]);
    +            if not assigned(generictype.owner) then
    +              begin
    +                if (generictype.typedef<>cundefinedtype) then
    +                  begin
    +                    { the generic parameters were parsed before the genericdef existed thus the
    +                      undefineddefs were added as part of the parent symtable }
    +                    if assigned(generictype.typedef.owner) then
    +                      generictype.typedef.owner.DefList.Extract(generictype.typedef);
    +                    generictype.typedef.changeowner(st);
    +                  end;
    +                st.insert(generictype);
    +                include(generictype.symoptions,sp_generic_para);
    +              end;
    +            def.genericparas.add(genericlist.nameofindex(i),generictype);
    +          end;
    +       end;
    +
         procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
           var
             gensym : ttypesym;
    diff --git a/compiler/ptype.pas b/compiler/ptype.pas
    index 38e2526e9f..c12e6eaa6e 100644
    --- a/compiler/ptype.pas
    +++ b/compiler/ptype.pas
    @@ -39,6 +39,8 @@ interface
           TSingleTypeOptions=set of TSingleTypeOption;
     
         procedure resolve_forward_types;
    +    procedure resolve_forward_generic_types;
    +    procedure maybe_add_used_by(def : tdef; sym: tsym);
     
         { reads a string, file type or a type identifier }
         procedure single_type(var def:tdef;options:TSingleTypeOptions);
    @@ -76,7 +78,7 @@ implementation
            jvmdef,
     {$endif}
            { modules }
    -       fmodule,
    +       fmodule, nobj,
            { pass 1 }
            node,
            nset,ncnv,ncon,nld,
    @@ -235,6 +237,126 @@ implementation
             current_module.checkforwarddefs.clear;
           end;
     
    +    procedure resolve_forward_generic_types;
    +      var
    +        i, r, oldIdx: longint;
    +        def, newdef : tobjectdef;
    +        hmodule : tmodule;
    +        fileinfo : tfileposinfo;
    +        old_block_type : tblock_type;
    +        oldcurrent_filepos : tfileposinfo;
    +        replaydepth : longint;
    +        genericdef:tstoreddef;
    +        hadtypetoken : boolean;
    +        recordbuf : tdynamicarray;
    +        vmtbuilder : tvmtbuilder;
    +      begin
    +        for i:= current_module.checkforwarddefs.Count-1 downto 0 do
    +          begin
    +            case tdef(current_module.checkforwarddefs[i]).typ of
    +              pointerdef,
    +              classrefdef:;
    +              objectdef :
    +                begin
    +                  def:=tobjectdef(current_module.checkforwarddefs[i]);
    +                  if not assigned(def.genericdef) then
    +                    continue;
    +
    +                  old_block_type:=block_type;
    +                  block_type:=bt_type;
    +
    +                  genericdef:=def.genericdef;
    +                  hmodule:=find_module_from_symtable(genericdef.owner);
    +                  if hmodule=nil then
    +                    internalerror(2018051202);
    +                  oldcurrent_filepos:=current_filepos;
    +                  { use the index the module got from the current compilation process }
    +                  current_filepos.moduleindex:=hmodule.unit_index;
    +                  current_tokenpos:=current_filepos;
    +                  if parse_generic then
    +                    begin
    +                      recordbuf:=current_scanner.recordtokenbuf;
    +                      current_scanner.recordtokenbuf:=nil;
    +                    end
    +                  else
    +                    recordbuf:=nil;
    +                  replaydepth:=current_scanner.replay_stack_depth;
    +
    +                  current_scanner.startreplaytokens(genericdef.generictokenbuf);
    +                  hadtypetoken:=false;
    +                  read_named_type(tdef(newdef),def.typesym,genericdef,def.genericparas,false,hadtypetoken);
    +                  ttypesym(def.typesym).typedef:=newdef;
    +                  newdef.typesym:=def.typesym;
    +
    +                  case newdef.typ of
    +                  { Build VMT indexes for classes and read hint directives }
    +                  objectdef:
    +                    begin
    +                      if replaydepth>current_scanner.replay_stack_depth then
    +                        begin
    +                          try_consume_hintdirective(newdef.typesym.symoptions,newdef.typesym.deprecatedmsg);
    +                          if replaydepth>current_scanner.replay_stack_depth then
    +                            consume(_SEMICOLON);
    +                        end;
    +
    +                      vmtbuilder:=TVMTBuilder.Create(newdef);
    +                      vmtbuilder.generate_vmt;
    +                      vmtbuilder.free;
    +                    end;
    +                  end;
    +                  current_filepos:=oldcurrent_filepos;
    +
    +                  { Consume the remainder of the buffer }
    +                  while current_scanner.replay_stack_depth>replaydepth do
    +                    consume(token);
    +                  if assigned(recordbuf) then
    +                    begin
    +                      if assigned(current_scanner.recordtokenbuf) then
    +                        internalerror(2018081002);
    +                      current_scanner.recordtokenbuf:=recordbuf;
    +                    end;
    +                  block_type:=old_block_type;
    +
    +                  if Assigned(def.used_by) then
    +                    begin
    +                      for r := 0 to def.used_by.Count-1 do
    +                        case tstoredsym(def.used_by[r]).typ of
    +                          fieldvarsym,
    +                          staticvarsym,
    +                          absolutevarsym,
    +                          paravarsym:
    +                            tabstractvarsym(def.used_by[r]).vardef := newdef;
    +                          propertysym:
    +                            tpropertysym(def.used_by[r]).propdef := newdef;
    +                          typesym:
    +                            ttypesym(def.used_by[r]).typedef := newdef;
    +                          else
    +                            internalerror(2018081003);
    +                        end;
    +                    end;
    +
    +                  oldIdx := current_module.globalsymtable.DefList.IndexOf(def);
    +                  newDef.defid:= def.defid;
    +                  current_module.pendingspecializations.Remove(def);
    +                  current_module.pendingspecializations.Add(newDef.typename, newDef);
    +                  current_module.globalsymtable.deletedef(def);
    +                  current_module.checkforwarddefs.Delete(i);
    +                end;
    +              else
    +                internalerror(2018081004);
    +            end;
    +          end;
    +      end;
    +
    +    procedure maybe_add_used_by(def : tdef; sym: tsym);
    +    begin
    +      if (def is tobjectdef) and (oo_is_forward in tobjectdef(def).objectoptions) and assigned(tobjectdef(def).genericdef) then
    +        begin
    +         if not Assigned(def.used_by) then
    +           def.used_by := TFPObjectList.Create(False);
    +         def.used_by.Add(sym);
    +        end;
    +    end;
     
         procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms,allowunitsym:boolean;out srsym:tsym;out srsymtable:tsymtable;out is_specialize:boolean); forward;
     
    diff --git a/compiler/symtype.pas b/compiler/symtype.pas
    index a59ba6ad43..c80929873c 100644
    --- a/compiler/symtype.pas
    +++ b/compiler/symtype.pas
    @@ -62,7 +62,9 @@ interface
              dbg_state   : tdefdbgstatus;
              defoptions  : tdefoptions;
              defstates   : tdefstates;
    +         used_by     : TFPObjectList;
              constructor create(dt:tdeftyp);
    +         destructor destroy;override;
              procedure buildderef;virtual;abstract;
              procedure buildderefimpl;virtual;abstract;
              procedure deref;virtual;abstract;
    @@ -283,6 +285,12 @@ implementation
              defid:=defid_not_registered;
           end;
     
    +    destructor tdef.destroy;
    +      begin
    +        used_by.free;
    +        inherited destroy;
    +      end;
    +
     
         function tdef.typename:string;
           begin
    -- 
    2.16.2.windows.1
    
    

Activities

Svetozar Belic

2018-08-13 14:03

reporter  

0001-Added-support-for-forward-declarations-of-generic-ty.patch (20,155 bytes)
From 1bb999c9a649728e2f70de96a59c37c90a57641d Mon Sep 17 00:00:00 2001
From: Svetozar Belic <toza.belic@gmail.com>
Date: Fri, 10 Aug 2018 19:26:24 +0200
Subject: [PATCH] Added support for forward declarations of generic types.

---
 compiler/pdecl.pas    |  19 ++++++--
 compiler/pdecobj.pas  |   7 +++
 compiler/pdecsub.pas  |   2 +-
 compiler/pdecvar.pas  |   9 +++-
 compiler/pgenutil.pas |  93 +++++++++++++++++++++++++++++++++++--
 compiler/ptype.pas    | 124 +++++++++++++++++++++++++++++++++++++++++++++++++-
 compiler/symtype.pas  |   8 ++++
 7 files changed, 253 insertions(+), 9 deletions(-)

diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas
index c5b5bcc921..bc07d08ed4 100644
--- a/compiler/pdecl.pas
+++ b/compiler/pdecl.pas
@@ -566,6 +566,11 @@ implementation
                     is_implicit_pointer_object_type(ttypesym(sym).typedef) and
                     (oo_is_forward in tobjectdef(ttypesym(sym).typedef).objectoptions) then
                   begin
+                    if assigned(generictypelist) and assigned(tobjectdef(ttypesym(sym).typedef).genericparas) then
+                      { check if generic parameters match the forward declaration }
+                      if not compare_generic_parameters(generictypelist, tobjectdef(ttypesym(sym).typedef).genericparas) then
+                        Message1(type_e_generic_declaration_does_not_match, ttypesym(sym).prettyname);
+
                     case token of
                       _CLASS :
                         objecttype:=default_class_type;
@@ -680,6 +685,7 @@ implementation
                     begin
                       istyperenaming:=true;
                       include(newtype.symoptions,sp_explicitrename);
+                      maybe_add_used_by(hdef, newtype);
                     end;
                   if isunique then
                     begin
@@ -690,9 +696,13 @@ implementation
                       if is_object(hdef) or
                          is_class_or_interface_or_dispinterface(hdef) then
                         begin
-                          { just create a child class type; this is
-                            Delphi-compatible }
-                          hdef:=cobjectdef.create(tobjectdef(hdef).objecttype,genorgtypename,tobjectdef(hdef),true);
+                          if oo_is_forward in tobjectdef(hdef).objectoptions then
+                            { Forward declarations are not allowed. }
+                            Message1(parser_e_forward_declaration_must_be_resolved, hdef.typesymbolprettyname)
+                          else
+                            { just create a child class type; this is
+                              Delphi-compatible }
+                            hdef:=cobjectdef.create(tobjectdef(hdef).objecttype,genorgtypename,tobjectdef(hdef),true);
                         end
                       else
                         begin
@@ -946,6 +956,9 @@ implementation
                 ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
                  ((m_final_fields in current_settings.modeswitches) and
                   (idtoken=_FINAL))));
+
+         resolve_forward_generic_types;
+
          { resolve type block forward declarations and restore a unit
            container for them }
          resolve_forward_types;
diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas
index 1e41f98a70..c116215f64 100644
--- a/compiler/pdecobj.pas
+++ b/compiler/pdecobj.pas
@@ -1499,6 +1499,13 @@ implementation
             { add to the list of definitions to check that the forward
               is resolved. this is required for delphi mode }
             current_module.checkforwarddefs.add(current_structdef);
+
+            { generic parameter types were registered globaly, remove them }
+            symtablestack.push(current_structdef.symtable);
+            update_generic_para_ownership(current_structdef,genericdef,genericlist);
+            symtablestack.pop(current_structdef.symtable);
+            current_structdef.genericdef := genericdef;
+
           end
         else
           begin
diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas
index e2b0c1712a..487a6f80c1 100644
--- a/compiler/pdecsub.pas
+++ b/compiler/pdecsub.pas
@@ -536,7 +536,7 @@ implementation
               { update varsym }
               vs.vardef:=hdef;
               vs.defaultconstsym:=defaultvalue;
-
+              maybe_add_used_by(hdef, vs);
               if (target_info.system in [system_powerpc_morphos,system_m68k_amiga]) then
                 begin
                   if locationstr<>'' then
diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas
index 4d39397e46..97746d1c07 100644
--- a/compiler/pdecvar.pas
+++ b/compiler/pdecvar.pas
@@ -448,7 +448,7 @@ implementation
            begin
               consume(_COLON);
               single_type(p.propdef,[stoAllowSpecialization]);
-
+              maybe_add_used_by(p.propdef, p);
               if is_dispinterface(astruct) and not is_automatable(p.propdef) then
                 Message1(type_e_not_automatable,p.propdef.typename);
 
@@ -1558,6 +1558,7 @@ implementation
          fieldvs   : tfieldvarsym;
          hstaticvs : tstaticvarsym;
          vs    : tabstractvarsym;
+         absvs : tabsolutevarsym;
          srsym : tsym;
          srsymtable : TSymtable;
          visibility : tvisibility;
@@ -1730,6 +1731,7 @@ implementation
                begin
                  fieldvs:=tfieldvarsym(sc[i]);
                  fieldvs.vardef:=hdef;
+                 maybe_add_used_by(hdef, fieldvs);
                  { insert any additional hint directives }
                  fieldvs.symoptions := fieldvs.symoptions + hintsymoptions;
                  if deprecatedmsg<>nil then
@@ -1794,6 +1796,11 @@ implementation
                        cnodeutils.insertbssdata(hstaticvs);
                      if vd_final in options then
                        hstaticvs.varspez:=vs_final;
+                     maybe_add_used_by(hdef, hstaticvs);
+                     { hstaticvs has generated an absvarsym, add it to used by as well }
+                     absvs := tabsolutevarsym(recst.Find(lower(generate_nested_name(recst,'_'))+'_'+fieldvs.name));
+                     if Assigned(absvs) then
+                       maybe_add_used_by(hdef, absvs);
                    end;
                  if removeclassoption then
                    begin
diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas
index 7760a4e134..d423fedb3f 100644
--- a/compiler/pgenutil.pas
+++ b/compiler/pgenutil.pas
@@ -43,9 +43,11 @@ uses
     function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef;
     function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;_prettyname:ansistring):tdef;
     function check_generic_constraints(genericdef:tstoreddef;paradeflist:tfpobjectlist;poslist:tfplist):boolean;
+    function compare_generic_parameters(deflist1, deflist2 : tfphashobjectlist): boolean;
     function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
     function parse_generic_specialization_types(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean;
     procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
+    procedure update_generic_para_ownership(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
     procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
     function generate_generic_name(const name:tidstring;specializename:ansistring;owner_hierarchy:string):tidstring;
     procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint);
@@ -299,6 +301,34 @@ uses
           end;
       end;
 
+    function compare_generic_parameters(deflist1, deflist2 : tfphashobjectlist):boolean;
+      var
+        i : integer;
+        ts1, ts2 : ttypesym;
+      begin
+        if deflist1.count<>deflist2.count then
+          internalerror(2018081091);
+
+        for i:=0 to deflist1.count-1 do
+          begin
+            ts1 := ttypesym(deflist1[i]);
+            ts2 := ttypesym(deflist2[i]);
+            if (ts1.typedef.typ<>ts2.typedef.typ) or (lower(ts1.realname)<>lower(ts2.Name)) then
+              exit(false);
+
+            if (ts1.typedef.typ = errordef) or (ts2.typedef.typ = errordef) or
+                (not assigned(tstoreddef(ts1.typedef).genconstraintdata)) then
+              continue;
+
+            if tstoreddef(ts1.typedef).genconstraintdata.flags <> tstoreddef(ts2.typedef).genconstraintdata.flags then
+              exit(false);
+
+            if gcf_class in tstoreddef(ts1.typedef).genconstraintdata.flags then
+              if tobjectdef(ts1.typedef).childof <> tobjectdef(ts2.typedef).childof then
+                exit(false);
+          end;
+        result := true;
+      end;
 
     function parse_generic_specialization_types_internal(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean;
       var
@@ -1056,9 +1086,13 @@ uses
                             consume(_SEMICOLON);
                         end;
 
-                      vmtbuilder:=TVMTBuilder.Create(tobjectdef(result));
-                      vmtbuilder.generate_vmt;
-                      vmtbuilder.free;
+                      { Do not build VMT for forward declarations, it will be built later when fully defined. }
+                      if not (oo_is_forward in tobjectdef(result).objectoptions) then
+                        begin
+                          vmtbuilder:=TVMTBuilder.Create(tobjectdef(result));
+                          vmtbuilder.generate_vmt;
+                          vmtbuilder.free;
+                        end;
                     end;
                   { handle params, calling convention, etc }
                   procvardef:
@@ -1384,6 +1418,7 @@ uses
         i : longint;
         generictype,sym : ttypesym;
         st : tsymtable;
+        hid : THashedIDString;
       begin
         def.genericdef:=genericdef;
         if not assigned(genericlist) then
@@ -1418,6 +1453,25 @@ uses
               end
             else
               begin
+                { check if the parameter sym/def was already created by a forward definition }
+                if generictype.realname[1]='$' then
+                  hid.id:=Copy(generictype.realname,2,255)
+                else
+                  hid.id:=Upper(generictype.realname);
+                if st.FindWithHash(hid) <> nil then
+                  begin
+                    { delete the typedef if defined, it will not be used }
+                    if (generictype.typedef<>cundefinedtype) and
+                       (assigned(generictype.typedef.owner)) then
+                         generictype.typedef.owner.deletedef(generictype.typedef);
+                    { delete the symbol as well }
+                    if assigned(generictype.owner) then
+                      generictype.owner.Delete(generictype)
+                    else
+                      generictype.free;
+                    continue;
+                  end;
+
                 if (generictype.typedef.typ=undefineddef) and (generictype.typedef<>cundefinedtype) then
                   begin
                     { the generic parameters were parsed before the genericdef existed thus the
@@ -1433,6 +1487,39 @@ uses
           end;
        end;
 
+    procedure update_generic_para_ownership(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
+      var
+        i : longint;
+        generictype,sym : ttypesym;
+        st : tsymtable;
+      begin
+        if not assigned(genericlist) or (genericlist.count<1) or (def.typ<>objectdef) then
+          exit;
+
+        st:=tobjectdef(def).symtable;
+
+        if not assigned(def.genericparas) then
+          def.genericparas:=tfphashobjectlist.create(false);
+        for i:=0 to genericlist.count-1 do
+          begin
+            generictype:=ttypesym(genericlist[i]);
+            if not assigned(generictype.owner) then
+              begin
+                if (generictype.typedef<>cundefinedtype) then
+                  begin
+                    { the generic parameters were parsed before the genericdef existed thus the
+                      undefineddefs were added as part of the parent symtable }
+                    if assigned(generictype.typedef.owner) then
+                      generictype.typedef.owner.DefList.Extract(generictype.typedef);
+                    generictype.typedef.changeowner(st);
+                  end;
+                st.insert(generictype);
+                include(generictype.symoptions,sp_generic_para);
+              end;
+            def.genericparas.add(genericlist.nameofindex(i),generictype);
+          end;
+       end;
+
     procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
       var
         gensym : ttypesym;
diff --git a/compiler/ptype.pas b/compiler/ptype.pas
index 38e2526e9f..c12e6eaa6e 100644
--- a/compiler/ptype.pas
+++ b/compiler/ptype.pas
@@ -39,6 +39,8 @@ interface
       TSingleTypeOptions=set of TSingleTypeOption;
 
     procedure resolve_forward_types;
+    procedure resolve_forward_generic_types;
+    procedure maybe_add_used_by(def : tdef; sym: tsym);
 
     { reads a string, file type or a type identifier }
     procedure single_type(var def:tdef;options:TSingleTypeOptions);
@@ -76,7 +78,7 @@ implementation
        jvmdef,
 {$endif}
        { modules }
-       fmodule,
+       fmodule, nobj,
        { pass 1 }
        node,
        nset,ncnv,ncon,nld,
@@ -235,6 +237,126 @@ implementation
         current_module.checkforwarddefs.clear;
       end;
 
+    procedure resolve_forward_generic_types;
+      var
+        i, r, oldIdx: longint;
+        def, newdef : tobjectdef;
+        hmodule : tmodule;
+        fileinfo : tfileposinfo;
+        old_block_type : tblock_type;
+        oldcurrent_filepos : tfileposinfo;
+        replaydepth : longint;
+        genericdef:tstoreddef;
+        hadtypetoken : boolean;
+        recordbuf : tdynamicarray;
+        vmtbuilder : tvmtbuilder;
+      begin
+        for i:= current_module.checkforwarddefs.Count-1 downto 0 do
+          begin
+            case tdef(current_module.checkforwarddefs[i]).typ of
+              pointerdef,
+              classrefdef:;
+              objectdef :
+                begin
+                  def:=tobjectdef(current_module.checkforwarddefs[i]);
+                  if not assigned(def.genericdef) then
+                    continue;
+
+                  old_block_type:=block_type;
+                  block_type:=bt_type;
+
+                  genericdef:=def.genericdef;
+                  hmodule:=find_module_from_symtable(genericdef.owner);
+                  if hmodule=nil then
+                    internalerror(2018051202);
+                  oldcurrent_filepos:=current_filepos;
+                  { use the index the module got from the current compilation process }
+                  current_filepos.moduleindex:=hmodule.unit_index;
+                  current_tokenpos:=current_filepos;
+                  if parse_generic then
+                    begin
+                      recordbuf:=current_scanner.recordtokenbuf;
+                      current_scanner.recordtokenbuf:=nil;
+                    end
+                  else
+                    recordbuf:=nil;
+                  replaydepth:=current_scanner.replay_stack_depth;
+
+                  current_scanner.startreplaytokens(genericdef.generictokenbuf);
+                  hadtypetoken:=false;
+                  read_named_type(tdef(newdef),def.typesym,genericdef,def.genericparas,false,hadtypetoken);
+                  ttypesym(def.typesym).typedef:=newdef;
+                  newdef.typesym:=def.typesym;
+
+                  case newdef.typ of
+                  { Build VMT indexes for classes and read hint directives }
+                  objectdef:
+                    begin
+                      if replaydepth>current_scanner.replay_stack_depth then
+                        begin
+                          try_consume_hintdirective(newdef.typesym.symoptions,newdef.typesym.deprecatedmsg);
+                          if replaydepth>current_scanner.replay_stack_depth then
+                            consume(_SEMICOLON);
+                        end;
+
+                      vmtbuilder:=TVMTBuilder.Create(newdef);
+                      vmtbuilder.generate_vmt;
+                      vmtbuilder.free;
+                    end;
+                  end;
+                  current_filepos:=oldcurrent_filepos;
+
+                  { Consume the remainder of the buffer }
+                  while current_scanner.replay_stack_depth>replaydepth do
+                    consume(token);
+                  if assigned(recordbuf) then
+                    begin
+                      if assigned(current_scanner.recordtokenbuf) then
+                        internalerror(2018081002);
+                      current_scanner.recordtokenbuf:=recordbuf;
+                    end;
+                  block_type:=old_block_type;
+
+                  if Assigned(def.used_by) then
+                    begin
+                      for r := 0 to def.used_by.Count-1 do
+                        case tstoredsym(def.used_by[r]).typ of
+                          fieldvarsym,
+                          staticvarsym,
+                          absolutevarsym,
+                          paravarsym:
+                            tabstractvarsym(def.used_by[r]).vardef := newdef;
+                          propertysym:
+                            tpropertysym(def.used_by[r]).propdef := newdef;
+                          typesym:
+                            ttypesym(def.used_by[r]).typedef := newdef;
+                          else
+                            internalerror(2018081003);
+                        end;
+                    end;
+
+                  oldIdx := current_module.globalsymtable.DefList.IndexOf(def);
+                  newDef.defid:= def.defid;
+                  current_module.pendingspecializations.Remove(def);
+                  current_module.pendingspecializations.Add(newDef.typename, newDef);
+                  current_module.globalsymtable.deletedef(def);
+                  current_module.checkforwarddefs.Delete(i);
+                end;
+              else
+                internalerror(2018081004);
+            end;
+          end;
+      end;
+
+    procedure maybe_add_used_by(def : tdef; sym: tsym);
+    begin
+      if (def is tobjectdef) and (oo_is_forward in tobjectdef(def).objectoptions) and assigned(tobjectdef(def).genericdef) then
+        begin
+         if not Assigned(def.used_by) then
+           def.used_by := TFPObjectList.Create(False);
+         def.used_by.Add(sym);
+        end;
+    end;
 
     procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms,allowunitsym:boolean;out srsym:tsym;out srsymtable:tsymtable;out is_specialize:boolean); forward;
 
diff --git a/compiler/symtype.pas b/compiler/symtype.pas
index a59ba6ad43..c80929873c 100644
--- a/compiler/symtype.pas
+++ b/compiler/symtype.pas
@@ -62,7 +62,9 @@ interface
          dbg_state   : tdefdbgstatus;
          defoptions  : tdefoptions;
          defstates   : tdefstates;
+         used_by     : TFPObjectList;
          constructor create(dt:tdeftyp);
+         destructor destroy;override;
          procedure buildderef;virtual;abstract;
          procedure buildderefimpl;virtual;abstract;
          procedure deref;virtual;abstract;
@@ -283,6 +285,12 @@ implementation
          defid:=defid_not_registered;
       end;
 
+    destructor tdef.destroy;
+      begin
+        used_by.free;
+        inherited destroy;
+      end;
+
 
     function tdef.typename:string;
       begin
-- 
2.16.2.windows.1

Thaddy de Koning

2018-08-14 08:46

reporter   ~0110027

Last edited: 2018-08-14 08:47

View 2 revisions

I applied it to test:
Ran into problems when TTest<T> = class; has multiple specializations?
Can you add tests for it? I may be expecting something wrong.
I will keep a copy of the patched fpc trunk but I reverted it for this reason.

Note I only test against {$mode delphi} and seldom touch {$mode objfpc} for generics.

Thaddy de Koning

2019-08-09 10:08

reporter   ~0117603

Any news? I also tested {$mode objfpc} by now, same answer.

Issue History

Date Modified Username Field Change
2018-08-13 14:03 Svetozar Belic New Issue
2018-08-13 14:03 Svetozar Belic File Added: 0001-Added-support-for-forward-declarations-of-generic-ty.patch
2018-08-14 08:46 Thaddy de Koning Note Added: 0110027
2018-08-14 08:47 Thaddy de Koning Note Edited: 0110027 View Revisions
2019-08-09 10:06 Sven Barth Tag Attached: generics
2019-08-09 10:08 Thaddy de Koning Note Added: 0117603
2019-08-15 14:03 Sven Barth Status new => acknowledged
2019-08-15 14:03 Sven Barth FPCTarget => -