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

* Support for DispInterface and DispID (bug ID 30716)

Browse Source 
git-svn-id: trunk@34754 -
This commit is contained in:
michael 2016-10-22 15:05:32 +00:00
parent fe896fbe3b
commit 52383fed98
6 changed files with 87 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -577,7 +577,7 @@ type
TPasGenericTemplateType = Class(TPasType);
TPasObjKind = (okObject, okClass, okInterface, okGeneric, okSpecialize,
okClassHelper,okRecordHelper,okTypeHelper);
okClassHelper,okRecordHelper,okTypeHelper, okDispInterface);
{ TPasClassType }
@ -768,6 +768,8 @@ type
ReadAccessor: TPasExpr;
WriteAccessor: TPasExpr;
ImplementsFunc: TPasExpr;
DispIDExpr : TPasexpr; // Can be nil.
StoredAccessor: TPasExpr; // can be nil, if StoredAccessorName is 'True' or 'False'
DefaultExpr: TPasExpr;
Args: TFPList; // List of TPasArgument objects
@ -1329,7 +1331,7 @@ const
'strict private', 'strict protected');
ObjKindNames: array[TPasObjKind] of string = (
'object', 'class', 'interface','class','class','class helper','record helper','type helper');
'object', 'class', 'interface','class','class','class helper','record helper','type helper','dispinterface');
ExprKindNames : Array[TPasExprKind] of string = (
'Ident',
@ -2466,6 +2468,7 @@ begin
ReleaseAndNil(TPasElement(ImplementsFunc));
ReleaseAndNil(TPasElement(StoredAccessor));
ReleaseAndNil(TPasElement(DefaultExpr));
ReleaseAndNil(TPasElement(DispIDExpr));
inherited Destroy;
end;

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

@ -1238,7 +1238,7 @@ function TPasParser.ParseType(Parent: TPasElement;
Const
// These types are allowed only when full type declarations
FullTypeTokens = [tkGeneric,{tkSpecialize,}tkClass,tkInterface,tkType];
FullTypeTokens = [tkGeneric,{tkSpecialize,}tkClass,tkInterface,tkDispInterface,tkType];
// Parsing of these types already takes care of hints
NoHintTokens = [tkProcedure,tkFunction];
var
@ -1261,7 +1261,10 @@ begin
case CurToken of
// types only allowed when full
tkObject: Result := ParseClassDecl(Parent, NamePos, TypeName, okObject,PM);
tkInterface: Result := ParseClassDecl(Parent, NamePos, TypeName, okInterface);
tkDispInterface:
Result := ParseClassDecl(Parent, NamePos, TypeName, okDispInterface);
tkInterface:
Result := ParseClassDecl(Parent, NamePos, TypeName, okInterface);
tkSpecialize: Result:=ParseSpecializeType(Parent,TypeName);
tkClass: Result := ParseClassDecl(Parent, NamePos, TypeName, okClass, PM);
tkType:
@ -3633,6 +3636,12 @@ begin
Result.WriteAccessorName := GetAccessorName(Result,Result.WriteAccessor);
NextToken;
end;
if CurTokenIsIdentifier('DISPID') then
begin
NextToken;
Result.DispIDExpr := DoParseExpression(Result,Nil);
NextToken;
end;
if CurTokenIsIdentifier('IMPLEMENTS') then
begin
Result.ImplementsName := GetAccessorName(Result,Result.ImplementsFunc);
@ -4716,7 +4725,7 @@ begin
tkVar,
tkIdentifier:
begin
if (AType.ObjKind=okInterface) then
if (AType.ObjKind in [okInterface,okDispInterface]) then
ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowed);
if CurToken=tkVar then
ExpectToken(tkIdentifier);
@ -4727,7 +4736,7 @@ begin
tkProcedure,tkFunction,tkConstructor,tkDestructor:
begin
SaveComments;
if (Curtoken in [tkConstructor,tkDestructor]) and (AType.ObjKind in [okInterface,okRecordHelper]) then
if (Curtoken in [tkConstructor,tkDestructor]) and (AType.ObjKind in [okInterface,okDispInterface,okRecordHelper]) then
ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
ProcessMethod(AType,False,CurVisibility);
end;
@ -4808,7 +4817,7 @@ begin
UngetToken
else
begin
if (AType.ObjKind=okInterface) and (CurToken = tkSquaredBraceOpen) then
if (AType.ObjKind in [okInterface,okDispInterface]) and (CurToken = tkSquaredBraceOpen) then
begin
NextToken;
AType.GUIDExpr:=DoParseExpression(AType);

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

@ -124,6 +124,7 @@ type
tkconstref,
tkconstructor,
tkdestructor,
tkdispinterface,
tkdiv,
tkdo,
tkdownto,
@ -486,6 +487,7 @@ const
'constref',
'constructor',
'destructor',
'dispinterface',
'div',
'do',
'downto',

4
packages/fcl-passrc/tests/tcbaseparser.pas
View File

@ -710,8 +710,8 @@ end;
procedure TTestParser.AssertEquals(const Msg: String; AExpected,
AActual: TPasObjKind);
begin
AssertEquals(Msg,GetEnumName(TypeInfo(TexprOpcode),Ord(AExpected)),
GetEnumName(TypeInfo(TexprOpcode),Ord(AActual)));
AssertEquals(Msg,GetEnumName(TypeInfo(TPasObjKind),Ord(AExpected)),
GetEnumName(TypeInfo(TPasObjKind),Ord(AActual)));
end;
procedure TTestParser.AssertEquals(const Msg: String; AExpected,

62
packages/fcl-passrc/tests/tcclasstype.pas
View File

@ -31,7 +31,7 @@ type
protected
Procedure StartClass (AParent : String = 'TObject'; InterfaceList : String = '');
Procedure StartClassHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject');
Procedure StartInterface (AParent : String = 'IInterface'; UUID : String = '');
Procedure StartInterface (AParent : String = 'IInterface'; UUID : String = ''; Disp : Boolean = False);
Procedure StartRecordHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject');
Procedure StartVisibility(A : TPasMemberVisibility);
Procedure EndClass(AEnd : String = 'end');
@ -146,8 +146,11 @@ type
procedure TestClassHelperParentedEmpty;
procedure TestClassHelperOneMethod;
procedure TestInterfaceEmpty;
procedure TestInterfaceDisp;
procedure TestInterfaceParentedEmpty;
procedure TestInterfaceOneMethod;
procedure TestInterfaceProperty;
procedure TestInterfaceDispProperty;
procedure TestInterfaceNoConstructor;
procedure TestInterfaceNoDestructor;
procedure TestInterfaceNoFields;
@ -259,12 +262,16 @@ begin
FParent:=AParent;
end;
procedure TTestClassType.StartInterface(AParent: String; UUID: String);
procedure TTestClassType.StartInterface(AParent: String; UUID: String;
Disp: Boolean = False);
Var
S : String;
begin
FStarted:=True;
S:='TMyClass = Interface';
if Disp then
S:='TMyClass = DispInterface'
else
S:='TMyClass = Interface';
if (AParent<>'') then
S:=S+' ('+AParent+')';
if (UUID<>'') then
@ -1567,6 +1574,17 @@ begin
AssertNull('No UUID',TheClass.GUIDExpr);
end;
procedure TTestClassType.TestInterfaceDisp;
begin
StartInterface('','',true);
EndClass();
ParseClass;
AssertEquals('Is interface',okDispInterface,TheClass.ObjKind);
AssertEquals('No members',0,TheClass.Members.Count);
AssertNull('No UUID',TheClass.GUIDExpr);
end;
procedure TTestClassType.TestInterfaceParentedEmpty;
begin
StartInterface('IInterface','');
@ -1591,6 +1609,44 @@ begin
AssertNull('No UUID',TheClass.GUIDExpr);
end;
procedure TTestClassType.TestInterfaceProperty;
begin
StartInterface('IInterface','');
AddMember('Function GetS : Integer');
AddMember('Property S : Integer Read GetS');
EndClass();
ParseClass;
AssertEquals('Is interface',okInterface,TheClass.ObjKind);
if TheClass.members.Count<1 then
Fail('No members for method');
AssertNotNull('Have method',FunctionMethod1);
AssertNotNull('Method proc type',FunctionMethod1.ProcType);
AssertMemberName('GetS');
AssertEquals('0 arguments',0,FunctionMethod1.ProcType.Args.Count) ;
AssertEquals('Default visibility',visDefault,FunctionMethod1.Visibility);
AssertEquals('No modifiers',[],FunctionMethod1.Modifiers);
AssertEquals('Default calling convention',ccDefault, FunctionMethod1.ProcType.CallingConvention);
AssertNull('No UUID',TheClass.GUIDExpr);
AssertNotNull('Have property',Property2);
AssertMemberName('S',Property2);
end;
procedure TTestClassType.TestInterfaceDispProperty;
begin
StartInterface('IInterface','',True);
AddMember('Property S : Integer DispID 1');
EndClass();
ParseClass;
AssertEquals('Is interface',okDispInterface,TheClass.ObjKind);
if TheClass.members.Count<1 then
Fail('No members for method');
AssertNotNull('Have property',Property1);
AssertMemberName('S',Property1);
AssertNotNull('Have property dispID',Property1.DispIDExpr);
AssertEquals('Have number',pekNumber,Property1.DispIDExpr.Kind);
AssertEquals('Have number','1', (Property1.DispIDExpr as TPrimitiveExpr).Value);
end;
procedure TTestClassType.TestInterfaceNoConstructor;
begin
StartInterface('','');

5
packages/fcl-passrc/tests/tcscanner.pas
View File

@ -120,6 +120,7 @@ type
procedure TestConst;
procedure TestConstructor;
procedure TestDestructor;
procedure TestDispinterface;
procedure TestDiv;
procedure TestDo;
procedure TestDownto;
@ -794,6 +795,10 @@ begin
TestToken(tkdestructor,'destructor');
end;
procedure TTestScanner.TestDispinterface;
begin
TestToken(tkdispinterface,'dispinterface');
end;
procedure TTestScanner.TestDiv;