Merged revisions 11403-11406 via svnmerge from

http://svn.freepascal.org/svn/fpc/trunk

........
  r11403 | peter | 2008-07-18 23:28:51 +0200 (Fri, 18 Jul 2008) | 2 lines
  
    * remove svn:executable property
........
  r11404 | peter | 2008-07-19 01:30:44 +0200 (Sat, 19 Jul 2008) | 9 lines
  
    * store specializations in globalsymtable for units, use localsymtable
      for programs. this allows speciailizations to be done in the interface
      part of the unit
    * support tobject.typemember.typemember nesting for generics
    * fix generic parameter checking when a typemember was created with the
      type of a parameter
    * known issue is nested specializations don't work yet because the token
      replay can't handled nested replays yet
........
  r11405 | peter | 2008-07-19 01:31:02 +0200 (Sat, 19 Jul 2008) | 2 lines
  
    * more generic tests
........
  r11406 | peter | 2008-07-19 02:02:36 +0200 (Sat, 19 Jul 2008) | 2 lines
  
    * handle (build)derefimpl also for objectdef so it also works for methods
........

git-svn-id: branches/fixes_2_2@11992 -

.gitattributes

@@ -7981,6 +7981,8 @@ tests/webtbs/tw1021.pp svneol=native#text/plain
 tests/webtbs/tw10210.pp svneol=native#text/plain
 tests/webtbs/tw10224.pp svneol=native#text/plain
 tests/webtbs/tw1023.pp svneol=native#text/plain
+tests/webtbs/tw10247.pp svneol=native#text/plain
+tests/webtbs/tw10247b.pp svneol=native#text/plain
 tests/webtbs/tw10320.pp svneol=native#text/plain
 tests/webtbs/tw10350.pp svneol=native#text/plain
 tests/webtbs/tw10371.pp svneol=native#text/plain
@@ -8048,6 +8050,10 @@ tests/webtbs/tw1132.pp svneol=native#text/plain
 tests/webtbs/tw1133.pp svneol=native#text/plain
 tests/webtbs/tw11349.pp svneol=native#text/plain
 tests/webtbs/tw11354.pp svneol=native#text/plain
+tests/webtbs/tw11431.pp svneol=native#text/plain
+tests/webtbs/tw11435b.pp svneol=native#text/plain
+tests/webtbs/tw11435c.pp svneol=native#text/plain
+tests/webtbs/tw11436.pp svneol=native#text/plain
 tests/webtbs/tw1152.pp svneol=native#text/plain
 tests/webtbs/tw1157.pp svneol=native#text/plain
 tests/webtbs/tw1157b.pp svneol=native#text/plain

compiler/pdecl.pas

@@ -381,6 +381,7 @@ implementation
             if token=_ID then
               begin
                 generictype:=ttypesym.create(orgpattern,cundefinedtype);
+                include(generictype.symoptions,sp_generic_para);
                 result.add(generictype);
               end;
             consume(_ID);

compiler/pdecsub.pas

@@ -892,6 +892,7 @@ implementation
         pd : tprocdef;
         isclassmethod : boolean;
         locationstr: string;
+        old_parse_generic,
         popclass : boolean;
       begin
         locationstr:='';
@@ -920,6 +921,7 @@ implementation
                     begin
                       if try_to_consume(_COLON) then
                        begin
+                         old_parse_generic:=parse_generic;
                          inc(testcurobject);
                          { Add ObjectSymtable to be able to find generic type definitions }
                          popclass:=false;
@@ -929,12 +931,14 @@ implementation
                            begin
                              symtablestack.push(pd._class.symtable);
                              popclass:=true;
+                             parse_generic:=(df_generic in pd._class.defoptions);
                            end;
                          single_type(pd.returndef,false);
                          if popclass then
                            symtablestack.pop(pd._class.symtable);
                          pd.test_if_fpu_result;
                          dec(testcurobject);
+                         parse_generic:=old_parse_generic;
 
                          if (target_info.system in [system_m68k_amiga]) then
                           begin

compiler/psub.pas

@@ -1767,6 +1767,7 @@ implementation
         oldsymtablestack   : tsymtablestack;
         pu : tused_unit;
         hmodule : tmodule;
+        specobj : tobjectdef;
       begin
         if not((tsym(p).typ=typesym) and
                (ttypesym(p).typedef.typesym=tsym(p)) and
@@ -1776,11 +1777,12 @@ implementation
           exit;
 
         { Setup symtablestack a definition time }
+        specobj:=tobjectdef(ttypesym(p).typedef);
         oldsymtablestack:=symtablestack;
         symtablestack:=tsymtablestack.create;
         if not assigned(tobjectdef(ttypesym(p).typedef).genericdef) then
           internalerror(200705151);
-        hmodule:=find_module_from_symtable(tobjectdef(ttypesym(p).typedef).genericdef.owner);
+        hmodule:=find_module_from_symtable(specobj.genericdef.owner);
         if hmodule=nil then
           internalerror(200705152);
         pu:=tused_unit(hmodule.used_units.first);
@@ -1796,29 +1798,32 @@ implementation
         if assigned(hmodule.localsymtable) then
           symtablestack.push(hmodule.localsymtable);
 
-        { definitions }
-        for i:=0 to tobjectdef(ttypesym(p).typedef).symtable.DefList.Count-1 do
+        { procedure definitions for classes or objects }
+        if is_class(specobj) or is_object(specobj) then
           begin
-            hp:=tdef(tobjectdef(ttypesym(p).typedef).symtable.DefList[i]);
-            if hp.typ=procdef then
-             begin
-               if assigned(tprocdef(hp).genericdef) and
-                 (tprocdef(hp).genericdef.typ=procdef) and
-                 assigned(tprocdef(tprocdef(hp).genericdef).generictokenbuf) then
+            for i:=0 to specobj.symtable.DefList.Count-1 do
+              begin
+                hp:=tdef(specobj.symtable.DefList[i]);
+                if hp.typ=procdef then
                  begin
-                   oldcurrent_filepos:=current_filepos;
-                   current_filepos:=tprocdef(tprocdef(hp).genericdef).fileinfo;
-                   { use the index the module got from the current compilation process }
-                   current_filepos.moduleindex:=hmodule.unit_index;
-                   current_tokenpos:=current_filepos;
-                   current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf);
-                   read_proc_body(nil,tprocdef(hp));
-                   current_filepos:=oldcurrent_filepos;
-                 end
-               else
-                 MessagePos1(tprocdef(tprocdef(hp).genericdef).fileinfo,sym_e_forward_not_resolved,tprocdef(tprocdef(hp).genericdef).fullprocname(false));
+                   if assigned(tprocdef(hp).genericdef) and
+                     (tprocdef(hp).genericdef.typ=procdef) and
+                     assigned(tprocdef(tprocdef(hp).genericdef).generictokenbuf) then
+                     begin
+                       oldcurrent_filepos:=current_filepos;
+                       current_filepos:=tprocdef(tprocdef(hp).genericdef).fileinfo;
+                       { use the index the module got from the current compilation process }
+                       current_filepos.moduleindex:=hmodule.unit_index;
+                       current_tokenpos:=current_filepos;
+                       current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf);
+                       read_proc_body(nil,tprocdef(hp));
+                       current_filepos:=oldcurrent_filepos;
+                     end
+                   else
+                     MessagePos1(tprocdef(tprocdef(hp).genericdef).fileinfo,sym_e_forward_not_resolved,tprocdef(tprocdef(hp).genericdef).fullprocname(false));
+                 end;
              end;
-         end;
+          end;
 
         { Restore symtablestack }
         symtablestack.free;

compiler/ptype.pas

@@ -97,6 +97,7 @@ implementation
         specializename : string;
         vmtbuilder : TVMTBuilder;
         onlyparsepara : boolean;
+        specializest : tsymtable;
       begin
         { retrieve generic def that we are going to replace }
         genericdef:=tstoreddef(tt);
@@ -155,8 +156,7 @@ implementation
         for i:=0 to st.SymList.Count-1 do
           begin
             sym:=tsym(st.SymList[i]);
-            if (sym.typ=typesym) and
-               (ttypesym(sym).typedef.typ=undefineddef) then
+            if (sp_generic_para in sym.symoptions) then
               begin
                 if not first then
                   consume(_COMMA)
@@ -191,10 +191,18 @@ implementation
            (aktobjectdef.objname^=uspecializename) then
           tt:=aktobjectdef;
 
+        { for units specializations can already be needed in the interface, therefor we
+          will use the global symtable. Programs don't have a globalsymtable and there we
+          use the localsymtable }
+        if current_module.is_unit then
+          specializest:=current_module.globalsymtable
+        else
+          specializest:=current_module.localsymtable;
+
         { Can we reuse an already specialized type? }
         if not assigned(tt) then
           begin
-            srsym:=tsym(tsymtable(current_module.localsymtable).find(uspecializename));
+            srsym:=tsym(specializest.find(uspecializename));
             if assigned(srsym) then
               begin
                 if srsym.typ<>typesym then
@@ -236,7 +244,7 @@ implementation
                 { Firsta new typesym so we can reuse this specialization and
                   references to this specialization can be handled }
                 srsym:=ttypesym.create(specializename,generrordef);
-                current_module.localsymtable.insert(srsym);
+                specializest.insert(srsym);
 
                 if not assigned(genericdef.generictokenbuf) then
                   internalerror(200511171);
@@ -379,7 +387,28 @@ implementation
                        again:=true;
                      end
                    else
-                     id_type(def,isforwarddef);
+                     begin
+                       id_type(def,isforwarddef);
+                       { handle types inside classes for generics, e.g. TNode.TLongint }
+                       while (token=_POINT) do
+                         begin
+                           if parse_generic then
+                             begin
+                                consume(_POINT);
+                                consume(_ID);
+                             end
+                            else if ((def.typ=objectdef) and (df_specialization in def.defoptions)) then
+                              begin
+                                symtablestack.push(tobjectdef(def).symtable);
+                                consume(_POINT);
+                                id_type(t2,isforwarddef);
+                                symtablestack.pop(tobjectdef(def).symtable);
+                                def:=t2;
+                              end
+                            else
+                              break;
+                         end;
+                     end;
                  end;
 
                else

compiler/symconst.pas

@@ -136,7 +136,9 @@ type
     sp_strictprivate,
     sp_strictprotected,
     sp_implicitrename,
-    sp_hidden
+    sp_hidden,
+    sp_hint_experimental,
+    sp_generic_para
   );
   tsymoptions=set of tsymoption;
 
@@ -147,7 +149,9 @@ type
     { type is a generic }
     df_generic,
     { type is a specialization of a generic type }
-    df_specialization
+    df_specialization,
+    { def has been copied from another def so symtable is not owned }
+    df_copied_def
   );
   tdefoptions=set of tdefoption;
 

compiler/symdef.pas

@@ -249,6 +249,8 @@ interface
           function GetTypeName:string;override;
           procedure buildderef;override;
           procedure deref;override;
+          procedure buildderefimpl;override;
+          procedure derefimpl;override;
           function  getparentdef:tdef;override;
           function  size : aint;override;
           function  alignment:shortint;override;
@@ -3862,6 +3864,24 @@ implementation
       end;
 
 
+    procedure tobjectdef.buildderefimpl;
+      var
+         i : longint;
+      begin
+         inherited buildderefimpl;
+         if not (df_copied_def in defoptions) then
+           tstoredsymtable(symtable).buildderefimpl;
+      end;
+
+
+    procedure tobjectdef.derefimpl;
+      begin
+         inherited derefimpl;
+         if not (df_copied_def in defoptions) then
+           tstoredsymtable(symtable).derefimpl;
+      end;
+
+
     function tobjectdef.getparentdef:tdef;
       begin
 {$warning TODO Remove getparentdef hack}

tests/tbs/tb0536.pp

@@ -0,0 +1,67 @@
+{$mode objfpc}{$h+}
+uses classes, sysutils;
+type
+        generic TNode<T> = class
+        type public
+                PT = ^T;
+        var private
+                Data: T;
+        public
+                constructor Create;
+                destructor Destroy; override;
+        end;
+
+        generic TContainer<T> = class
+        type public
+                TTNode = specialize TNode<T>;
+        var
+        private
+                Data: TTNode;
+        public
+                constructor Create;
+                destructor Destroy; override;
+
+                function GetAddr: TTNode.PT;
+                procedure SetV(v: TTNode.T);
+        end;
+
+constructor TNode.Create;
+begin
+end;
+
+destructor TNode.Destroy;
+begin
+        inherited Destroy;
+end;
+
+constructor TContainer.Create;
+begin
+  Data:=TTNode.Create;
+end;
+
+destructor TContainer.Destroy;
+begin
+  Data.Free;
+        inherited Destroy;
+end;
+
+function TContainer.GetAddr: TTNode.PT;
+begin
+        result := @Data.Data;
+end;
+
+
+procedure TContainer.SetV(v: TTNode.T);
+begin
+  Data.Data:=v;
+end;
+
+type
+  TStringContainer=specialize TContainer<String>;
+var
+  c : TStringContainer;
+begin
+  c:=TStringContainer.Create;
+  c.Set('abc');
+  Writeln(HexStr(c.Get));
+end.

tests/webtbs/tw10247b.pp

@@ -0,0 +1,42 @@
+{$mode objfpc}{$h+}
+type
+        generic TNode<T> = class
+        type public
+                PT = T;
+        var private
+                Data: T;
+        public
+                constructor Create;
+                destructor Destroy; override;
+        end;
+
+        TTNodeLongint = specialize TNode<Longint>;
+
+        TTNodeString = specialize TNode<String>;
+
+constructor TNode.Create;
+begin
+end;
+
+destructor TNode.Destroy;
+begin
+        inherited Destroy;
+end;
+
+
+function GetIntNode: TTNodeLongint.T;
+begin
+        result := 10;
+end;
+
+
+function GetStringNode: TTNodeString.PT;
+begin
+        result := 'abc';
+end;
+
+begin
+  writeln(GetIntNode);
+  writeln(GetStringNode);
+end.
+

tests/webtbs/tw11431.pp

@@ -0,0 +1,19 @@
+{$mode objfpc}
+unit tw11431;
+
+interface
+
+uses sysutils;
+
+type
+
+  generic IGenericCollection<_T> = interface
+  end;
+
+  generic CGenericCollection<_T> = class( IGenericCollection)
+  end;
+
+implementation
+
+
+end.

tests/webtbs/tw11435b.pp

@@ -0,0 +1,20 @@
+unit tw11435b;
+{$MODE ObjFPC}
+
+interface
+
+type
+  generic gCBla<_T> = class
+    function add( item: _T) : integer;
+  end;
+
+  CBla = specialize gCBla<Pointer>;
+
+implementation
+
+function gCBla.add( item: _T) : integer;
+begin
+  result := 0;
+end;
+
+end.

tests/webtbs/tw11435c.pp

@@ -0,0 +1,33 @@
+unit tw11435c;
+
+{$MODE ObjFPC}
+
+interface
+
+type
+  generic TList<_T>=class(TObject)
+    type public
+       TCompareFunc = function(const Item1, Item2: _T): Integer;
+    var public
+      data : _T;
+    procedure Add(item: _T);
+    procedure Sort(compare: TCompareFunc);
+  end;
+
+type
+  TA = specialize TList<byte>;
+
+implementation
+
+procedure TList.Add(item: _T);
+begin
+  data:=item;
+end;
+
+procedure TList.Sort(compare: TCompareFunc);
+begin
+  if compare(data, 20) <= 0 then
+    halt(1);
+end;
+
+end.

tests/webtbs/tw11436.pp

@@ -0,0 +1,15 @@
+unit tw11436;
+{$MODE ObjFPC}
+
+interface
+
+type
+  generic gIBla<_T> = interface
+    function add( item: _T) : integer;
+  end;
+
+  IBla = specialize gIBla<byte>;
+
+implementation
+
+end.