* Support for generics

git-svn-id: trunk@19621 -

packages/fcl-passrc/examples/test_parser.pp

@@ -1439,16 +1439,47 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
    if assigned(pc) then
     begin
      s:=GetIndent(indent);
-     write(s,pc.Name,'=');
+     if (pc.ObjKind=okGeneric) then
+       begin
+       write(s,'generic ',pc.Name);
+       for l:=0 to pc.GenericTemplateTypes.Count-1 do
+          begin
+          if l=0 then
+           Write('<')
+          else
+           Write(',');
+          Write(TPasGenericTemplateType(pc.GenericTemplateTypes[l]).Name);
+          end;
+       Write('> = ');
+       end
+     else
+       write(s,pc.Name,' = ');
      if pc.IsPacked then write('packed ');
      case pc.ObjKind of
       okObject:write('Object');
       okClass:write('Class');
       okInterface:write('Interface');
+      okGeneric:write('class');
+      okspecialize : write('specialize');
      end;
      if assigned(pc.AncestorType) and (pc.AncestorType.ElementTypeName <> '') then
-        write('(',pc.AncestorType.Name,')');
-
+        begin
+        if pc.ObjKind<>okspecialize then
+          write('(',pc.AncestorType.Name,')')
+        else
+          begin
+          write(' ',pc.AncestorType.Name);
+          for l:=0 to pc.GenericTemplateTypes.Count-1 do
+           begin
+           if l=0 then
+            Write('<')
+           else
+            Write(',');
+           Write(TPasGenericTemplateType(pc.GenericTemplateTypes[l]).Name);
+           end;
+          Write('>');
+          end;
+        end;
      if pc.IsForward or pc.IsShortDefinition then //pparser.pp: 3417 :class(anchestor); is allowed !
       begin
        writeln(';');
@@ -1562,6 +1593,7 @@ procedure GetTypes(pe:TPasElement; lindent:integer);
          vars.free;
        end
         else  writeln;//(';'); //x=class(y);
+
      writeln(s,'end;');
     end;
   end;

packages/fcl-passrc/examples/testunit1.pp

@@ -147,7 +147,15 @@ interface
  Procedure externalnameProc; external name 'aname';
  Procedure externallibnameProc; external 'alibrary' name 'aname';
 
-  
+Type
+ generic TFPGListEnumerator<T> = class(TObject)
+ protected
+    FList: TFPSList;
+    FPosition: Integer;
+    function GetCurrent: T;
+ end;                 
+ TFPGListEnumeratorSpec = specialize TFPGListEnumerator<T>; 
+ 
 Implementation
 
 

packages/fcl-passrc/src/pastree.pp

@@ -45,6 +45,8 @@ resourcestring
   SPasTreeObjectType = 'object';
   SPasTreeClassType = 'class';
   SPasTreeInterfaceType = 'interface';
+  SPasTreeGenericType = 'generic class';
+  SPasTreeSpecializedType = 'specialized class type';
   SPasTreeArgument = 'argument';
   SPasTreeProcedureType = 'procedure type';
   SPasTreeResultElement = 'function result';
@@ -453,8 +455,8 @@ type
     Variants: TList;	// array of TPasVariant elements, may be nil!
   end;
 
-
-  TPasObjKind = (okObject, okClass, okInterface);
+  TPasGenericTemplateType = Class(TPasElement);
+  TPasObjKind = (okObject, okClass, okInterface, okGeneric, okSpecialize);
 
   { TPasClassType }
 
@@ -475,8 +477,11 @@ type
     ClassVars: TList;   // class vars
     Modifiers: TStringList;
     Interfaces : TList;
+    GenericTemplateTypes : TList;
   end;
 
+
+
   TArgumentAccess = (argDefault, argConst, argVar, argOut);
 
   { TPasArgument }
@@ -1012,7 +1017,7 @@ const
     'default', 'private', 'protected', 'public', 'published', 'automated','strict private', 'strict protected');
 
   ObjKindNames: array[TPasObjKind] of string = (
-    'object', 'class', 'interface');
+    'object', 'class', 'interface','class','class');
   
   OpcodeStrings : Array[TExprOpCode] of string = 
        ('','+','-','*','/','div','mod','**',
@@ -1081,6 +1086,8 @@ begin
     okObject: Result := SPasTreeObjectType;
     okClass: Result := SPasTreeClassType;
     okInterface: Result := SPasTreeInterfaceType;
+    okGeneric : Result := SPasTreeGenericType;
+    okSpecialize : Result := SPasTreeSpecializedType;
   end;
 end;
 
@@ -1366,6 +1373,8 @@ begin
   Modifiers := TStringList.Create;
   ClassVars := TList.Create;
   Interfaces:= TList.Create;
+  GenericTemplateTypes:=TList.Create;
+
 end;
 
 destructor TPasClassType.Destroy;
@@ -1380,6 +1389,9 @@ begin
   Modifiers.Free;
   ClassVars.Free;
   Interfaces.Free;
+  for i := 0 to GenericTemplateTypes.Count - 1 do
+    TPasElement(GenericTemplateTypes[i]).Release;
+  GenericTemplateTypes.Free;
   inherited Destroy;
 end;
 

packages/fcl-passrc/src/pparser.pp

@@ -30,6 +30,7 @@ resourcestring
   SParserErrorAtToken = '%s at token "%s" in file %s at line %d column %d';
   SParserUngetTokenError = 'Internal error: Cannot unget more tokens, history buffer is full';
   SParserExpectTokenError = 'Expected "%s"';
+  SParserExpectToken2Error = 'Expected "%s" or "%s"';
   SParserExpectedCommaRBracket = 'Expected "," or ")"';
   SParserExpectedCommaSemicolon = 'Expected "," or ";"';
   SParserExpectedCommaColon = 'Expected "," or ":"';
@@ -118,7 +119,9 @@ type
     FTokenStringBuffer: array[0..1] of String;
     FTokenBufferIndex: Integer; // current index in FTokenBuffer
     FTokenBufferSize: Integer; // maximum valid index in FTokenBuffer
+    procedure DoParseClassType(AType: TPasClassType; SourceFileName: String; SourceLineNumber: Integer);
     procedure ParseExc(const Msg: String);
+    procedure ReadGenericArguments(List : TList;Parent : TPasElement; IsSpecialize : Boolean);
   protected
     function OpLevel(t: TToken): Integer;
     Function TokenToExprOp (AToken : TToken) : TExprOpCode;
@@ -181,8 +184,7 @@ type
     function ParseProcedureOrFunctionDecl(Parent: TPasElement;
       ProcType: TProcType): TPasProcedure;
     procedure ParseRecordDecl(Parent: TPasRecordType; IsNested: Boolean);   // !!!: Optimize this. We have 3x the same wrapper code around it.
-    function ParseClassDecl(Parent: TPasElement; const AClassName: String;
-      AObjKind: TPasObjKind): TPasType;
+    function ParseClassDecl(Parent: TPasElement; const AClassName: String;   AObjKind: TPasObjKind): TPasType;
     procedure ParseProperty(Element:TPasElement);
     procedure ParseProcBeginBlock(Parent: TProcedureBody);
     procedure ParseStatement(Parent: TPasImplBlock;
@@ -1408,6 +1410,7 @@ var
   i,j: Integer;
   VarEl: TPasVariable;
   PropEl : TPasProperty;
+  TypeName: String;
 begin
   CurBlock := declNone;
   while True do
@@ -1592,6 +1595,26 @@ begin
             ParseExc(SParserSyntaxError);
           end;
         end;
+      tkGeneric:
+        begin
+          if CurBlock <> declType then
+            ParseExc(SParserSyntaxError);
+          TypeName := ExpectIdentifier;
+          ClassEl := TPasClassType(Engine.CreateElement(TPasClassType,TypeName,Declarations, Scanner.CurFilename, Scanner.CurRow));
+          ClassEl.ObjKind:=okGeneric;
+          try
+            ReadGenericArguments(ClassEl.GenericTemplateTypes,ClassEl,False);
+          Except
+            List.Free;
+            Raise;
+          end;
+          ExpectToken(tkEqual);
+          ExpectToken(tkClass);
+          NextToken;
+          DoParseClassType(ClassEl, Scanner.CurFilename, Scanner.CurRow);
+          Declarations.Declarations.Add(ClassEl);
+          Declarations.Classes.Add(ClassEl)
+        end;
       tkbegin:
         begin
         if Declarations is TProcedureBody then
@@ -1705,6 +1728,23 @@ begin
   end;
 end;
 
+procedure TPasParser.ReadGenericArguments(List : TList;Parent : TPasElement; IsSpecialize : Boolean);
+
+Var
+  N : String;
+
+begin
+  ExpectToken(tkLessThan);
+  repeat
+    N:=ExpectIdentifier;
+    List.Add(CreateElement(TPasGenericTemplateType,N,Parent));
+    NextToken;
+    if not (CurToken in [tkComma, tkGreaterThan]) then
+      ParseExc(Format(SParserExpectToken2Error,
+        [TokenInfos[tkComma], TokenInfos[tkGreaterThan]]));
+  until CurToken = tkGreaterThan;
+end;
+
 // Starts after the type name
 function TPasParser.ParseTypeDecl(Parent: TPasElement): TPasType;
 var
@@ -1935,6 +1975,16 @@ begin
           raise;
         end;
       end;
+    tkSpecialize:
+      begin
+        Result := TPasClassType(Engine.CreateElement(TPasClassType, TypeName,
+          Parent, Scanner.CurFilename, Scanner.CurRow));
+        TPasClassType(Result).ObjKind := okSpecialize;
+        TPasClassType(Result).AncestorType := ParseType(nil);
+        TPasClassType(Result).IsShortDefinition:=True;
+        ReadGenericArguments(TPasClassType(Result).GenericTemplateTypes,Result,True);
+        ExpectToken(tkSemicolon);
+      end;
     else
     begin
       UngetToken;
@@ -3187,8 +3237,8 @@ begin
 end;
 
 // Starts after the "class" token
-function TPasParser.ParseClassDecl(Parent: TPasElement;
-  const AClassName: String; AObjKind: TPasObjKind): TPasType;
+Procedure TPasParser.DoParseClassType(AType : TPasClassType; SourceFileName : String; SourceLineNumber : Integer);
+
 var
   CurVisibility: TPasMemberVisibility;
 
@@ -3204,7 +3254,7 @@ var
     HasReturnValue:=false;
     ExpectIdentifier;
     Name := CurTokenString;
-    Owner := CheckIfOverloaded(TPasClassType(Result), Name);
+    Owner := CheckIfOverloaded(AType, Name);
     case ProcType of
      ptFunction:
     begin
@@ -3251,7 +3301,7 @@ var
     if Owner.ClassType = TPasOverloadedProc then
       TPasOverloadedProc(Owner).Overloads.Add(Proc)
     else
-      TPasClassType(Result).Members.Add(Proc);
+      AType.Members.Add(Proc);
 
     if HasReturnValue then
       pt := ptFunction
@@ -3321,56 +3371,31 @@ var
   end;
 
 var
-  s, SourceFilename: String;
-  i, SourceLinenumber: Integer;
+  s: String;
+  i: Integer;
   VarList: TList;
   Element: TPasElement;
   isStrict: Boolean;
 begin
   isStrict:=False;
-
-  // Save current parsing position to get it correct in all cases
-  SourceFilename := Scanner.CurFilename;
-  SourceLinenumber := Scanner.CurRow;
-
-  NextToken;
-
-  if (AObjKind = okClass) and (CurToken = tkOf) then
-  begin
-    Result := TPasClassOfType(Engine.CreateElement(TPasClassOfType, AClassName,
-      Parent, SourceFilename, SourceLinenumber));
-    ExpectIdentifier;
-    UngetToken;                // Only names are allowed as following type
-    TPasClassOfType(Result).DestType := ParseType(Result);
-    ExpectToken(tkSemicolon);
-    exit;
-  end;
-
-
-  Result := TPasClassType(Engine.CreateElement(TPasClassType, AClassName,
-    Parent, SourceFilename, SourceLinenumber));
-
-  try
-    TPasClassType(Result).ObjKind := AObjKind;
-
-    // nettism/new delphi features
-    if (CurToken = tkIdentifier) and (AObjKind = okClass) then begin
-      s := LowerCase(CurTokenString);
-      if (s = 'sealed') or (s = 'abstract') then begin
-        TPasClassType(Result).Modifiers.Add(s);
-        NextToken;
-      end;
+  // nettism/new delphi features
+  if (CurToken = tkIdentifier) and (Atype.ObjKind  in [okClass,okGeneric]) then begin
+    s := LowerCase(CurTokenString);
+    if (s = 'sealed') or (s = 'abstract') then begin
+      AType.Modifiers.Add(s);
+      NextToken;
     end;
+  end;
 
     // Parse ancestor list
     if CurToken = tkBraceOpen then
     begin
-      TPasClassType(Result).AncestorType := ParseType(nil);
+      AType.AncestorType := ParseType(nil);
       {$ifdef Inheritancewarnings}
-        s:=TPasClassType(Result).AncestorType.pathname;
+        s:=AType.AncestorType.pathname;
         if pos('#',s)=0 then
           begin
-            writeln('Note: ', TPasClassType(Result).pathname,'''s ancestor ',s, ' at ',sourcefilename,':',sourcelinenumber,' cannot be resolved fully');
+            writeln('Note: ', AType.pathname,'''s ancestor ',s, ' at ',sourcefilename,':',sourcelinenumber,' cannot be resolved fully');
           end;
       {$endif}
       while True do
@@ -3383,22 +3408,22 @@ begin
         //ExpectIdentifier;
         Element:=ParseType(Nil); // search interface.
         if assigned(element) then
-          TPasClassType(Result).Interfaces.add(element);
+          AType.Interfaces.add(element);
         // !!!: Store interface name
       end;
       NextToken;
     end
     else
-      TPasClassType(Result).isForward:=CurToken=tkSemicolon;
+      Atype.isForward:=CurToken=tkSemicolon;
     if CurToken = tkSemicolon then
-       TPasClassType(Result).IsShortDefinition:=true;
+       AType.IsShortDefinition:=true;
 
     if CurToken <> tkSemicolon then
     begin
-      if ( AObjKind = okInterface ) and ( CurToken = tkSquaredBraceOpen ) then
+      if ( AType.ObjKind = okInterface ) and ( CurToken = tkSquaredBraceOpen ) then
       begin
         ExpectToken(tkString);
-        TPasClassType(Result).InterfaceGUID := CurTokenString;
+        AType.InterfaceGUID := CurTokenString;
         ExpectToken(tkSquaredBraceClose);
       end;
       CurVisibility := visDefault;
@@ -3431,12 +3456,12 @@ begin
               begin
                 VarList := TList.Create;
                 try
-                  ParseInlineVarDecl(Result, VarList, CurVisibility, False);
+                  ParseInlineVarDecl(AType, VarList, CurVisibility, False);
                   for i := 0 to VarList.Count - 1 do
                   begin
                     Element := TPasElement(VarList[i]);
                     Element.Visibility := CurVisibility;
-                    TPasClassType(Result).Members.Add(Element);
+                    AType.Members.Add(Element);
                   end;
                 finally
                   VarList.Free;
@@ -3466,24 +3491,57 @@ begin
              NextToken;
              if CurToken = tkprocedure then ProcessMethod(ptClassProcedure)
               else ProcessMethod(ptClassFunction);
-            end;               
+            end;
           tkProperty:
             begin
               ExpectIdentifier;
-              Element := CreateElement(TPasProperty, CurTokenString, Result, CurVisibility);
-              TPasClassType(Result).Members.Add(Element);
+              Element := CreateElement(TPasProperty, CurTokenString, AType, CurVisibility);
+              AType.Members.Add(Element);
               ParseProperty(Element);
             end;
           tkVar: // vars (nettism/new delphi features)
-            if AObjKind<>okClass then ExpectToken(tkSemicolon);
+            if (not (AType.ObjKind in [okClass,okGeneric])) then
+              ExpectToken(tkSemicolon);
           //todo: class vars
         end; // end case
         NextToken;
       end;
       // Eat semicolon after class...end
-      CheckHint(result,true);
+      CheckHint(AType,true);
 //      ExpectToken(tkSemicolon);
     end;
+end;
+
+function TPasParser.ParseClassDecl(Parent: TPasElement; const AClassName: String; AObjKind: TPasObjKind): TPasType;
+
+Var
+  SourcefileName : string;
+  SourceLineNumber : Integer;
+
+begin
+  // Save current parsing position to get it correct in all cases
+  SourceFilename := Scanner.CurFilename;
+  SourceLinenumber := Scanner.CurRow;
+
+  NextToken;
+
+  if (AObjKind = okClass) and (CurToken = tkOf) then
+  begin
+    Result := TPasClassOfType(Engine.CreateElement(TPasClassOfType, AClassName,
+      Parent, SourceFilename, SourceLinenumber));
+    ExpectIdentifier;
+    UngetToken;                // Only names are allowed as following type
+    TPasClassOfType(Result).DestType := ParseType(Result);
+    ExpectToken(tkSemicolon);
+    exit;
+  end;
+
+  Result := TPasClassType(Engine.CreateElement(TPasClassType, AClassName,
+    Parent, SourceFilename, SourceLinenumber));
+
+  try
+    TPasClassType(Result).ObjKind := AObjKind;
+    DoParseClassType(TPasClassType(Result),SourceFileName,SourceLineNumber);
   except
     Result.Free;
     raise;

packages/fcl-passrc/src/pscanner.pp

@@ -94,6 +94,7 @@ type
     tkfinally,
     tkfor,
     tkfunction,
+    tkgeneric,
     tkgoto,
     tkif,
     tkimplementation,
@@ -125,6 +126,7 @@ type
     tkset,
     tkshl,
     tkshr,
+    tkspecialize,
 //    tkstring,
     tkthen,
     tkthreadvar,
@@ -298,6 +300,7 @@ const
     'finally',
     'for',
     'function',
+    'generic',
     'goto',
     'if',
     'implementation',
@@ -329,6 +332,7 @@ const
     'set',
     'shl',
     'shr',
+    'specialize',
 //    'string',
     'then',
     'threadvar',