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