Browse Source

Fix for Mantis #26176. Don't handle "type helper" as unique.

ptype.pas:
  * read_named_type: change hadtypetoken from a value to a var parameter and set it to false if a type helper is parsed so that calling code does not handle it as unique
  * read_anon_type: handle that hadtypetoken is now a var parameter

pgenutil.pas, generate_specialization:
  * handle that hadtypetoken of read_named_type is now a var parameter

+ added test

git-svn-id: trunk@27870 -
svenbarth 11 years ago
parent
commit
1bbcc08a8b
4 changed files with 29 additions and 4 deletions
  1. 1 0
      .gitattributes
  2. 3 1
      compiler/pgenutil.pas
  3. 9 3
      compiler/ptype.pas
  4. 16 0
      tests/webtbf/tw26176.pp

+ 1 - 0
.gitattributes

@@ -12747,6 +12747,7 @@ tests/webtbf/tw25861.pp svneol=native#text/plain
 tests/webtbf/tw25862.pp svneol=native#text/plain
 tests/webtbf/tw25915.pp svneol=native#text/pascal
 tests/webtbf/tw25951.pp svneol=native#text/pascal
+tests/webtbf/tw26176.pp svneol=native#text/pascal
 tests/webtbf/tw26193.pp svneol=native#text/pascal
 tests/webtbf/tw2657.pp svneol=native#text/plain
 tests/webtbf/tw2670.pp svneol=native#text/plain

+ 3 - 1
compiler/pgenutil.pas

@@ -384,6 +384,7 @@ uses
         st  : TSymtable;
         srsym : tsym;
         pt2 : tnode;
+        hadtypetoken,
         errorrecovery,
         found,
         first,
@@ -824,7 +825,8 @@ uses
                 else
                   recordbuf:=nil;
                 current_scanner.startreplaytokens(genericdef.generictokenbuf);
-                read_named_type(tt,srsym,genericdef,generictypelist,false,false);
+                hadtypetoken:=false;
+                read_named_type(tt,srsym,genericdef,generictypelist,false,hadtypetoken);
                 current_filepos:=oldcurrent_filepos;
                 ttypesym(srsym).typedef:=tt;
                 tt.typesym:=srsym;

+ 9 - 3
compiler/ptype.pas

@@ -44,7 +44,7 @@ interface
     procedure single_type(var def:tdef;options:TSingleTypeOptions);
 
     { reads any type declaration, where the resulting type will get name as type identifier }
-    procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:tfphashobjectlist;parseprocvardir:boolean;hadtypetoken:boolean);
+    procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:tfphashobjectlist;parseprocvardir:boolean;var hadtypetoken:boolean);
 
     { reads any type declaration }
     procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
@@ -946,7 +946,7 @@ implementation
 
 
     { reads a type definition and returns a pointer to it }
-    procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:tfphashobjectlist;parseprocvardir:boolean;hadtypetoken:boolean);
+    procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:tfphashobjectlist;parseprocvardir:boolean;var hadtypetoken:boolean);
       var
         pt : tnode;
         tt2 : tdef;
@@ -1802,6 +1802,9 @@ implementation
                     ([m_delphi,m_type_helpers]*current_settings.modeswitches=[m_type_helpers]) and
                     (token=_ID) and (idtoken=_HELPER) then
                   begin
+                    { reset hadtypetoken, so that calling code knows that it should not be handled
+                      as a "unique" type }
+                    hadtypetoken:=false;
                     consume(_HELPER);
                     def:=object_dec(odt_helper,name,newsym,genericdef,genericlist,nil,ht_type);
                   end
@@ -1815,8 +1818,11 @@ implementation
 
 
     procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
+      var
+        hadtypetoken : boolean;
       begin
-        read_named_type(def,nil,nil,nil,parseprocvardir,false);
+        hadtypetoken:=false;
+        read_named_type(def,nil,nil,nil,parseprocvardir,hadtypetoken);
       end;
 
 

+ 16 - 0
tests/webtbf/tw26176.pp

@@ -0,0 +1,16 @@
+{ %fail }
+
+program tw26176;
+
+{$MODE OBJFPC}
+{$MODESWITCH TYPEHELPERS}
+
+type
+  TIH = type helper for Int32
+    // NO (!) error - Forward declaration not solved "Foo(TObject);"
+    procedure Foo(Sender: TObject);
+  end;
+
+begin
+end.
+