paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-23 08:29:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Support for generics

Browse Source 
git-svn-id: trunk@19621 -
This commit is contained in:
michael 2011-11-11 15:08:17 +00:00
parent 9324726374
commit 5ea8e65ea2
5 changed files with 176 additions and 62 deletions

38
packages/fcl-passrc/examples/test_parser.pp
View File

@ -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;

10
packages/fcl-passrc/examples/testunit1.pp
View File

@ -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

18
packages/fcl-passrc/src/pastree.pp
View File

@ -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;

168
packages/fcl-passrc/src/pparser.pp
View File

@ -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;

4
packages/fcl-passrc/src/pscanner.pp
View File

@ -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',