From 52383fed9868df82ed2c93c19d33d1989f54d16f Mon Sep 17 00:00:00 2001 From: michael Date: Sat, 22 Oct 2016 15:05:32 +0000 Subject: [PATCH] * Support for DispInterface and DispID (bug ID 30716) git-svn-id: trunk@34754 - --- packages/fcl-passrc/src/pastree.pp | 7 ++- packages/fcl-passrc/src/pparser.pp | 19 +++++-- packages/fcl-passrc/src/pscanner.pp | 2 + packages/fcl-passrc/tests/tcbaseparser.pas | 4 +- packages/fcl-passrc/tests/tcclasstype.pas | 62 ++++++++++++++++++++-- packages/fcl-passrc/tests/tcscanner.pas | 5 ++ 6 files changed, 87 insertions(+), 12 deletions(-) diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index ac24af48c2..c8c2eb9dce 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -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; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index a561a2b2e1..86586041f3 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -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); diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index 30bc76f60d..2e9d615996 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -124,6 +124,7 @@ type tkconstref, tkconstructor, tkdestructor, + tkdispinterface, tkdiv, tkdo, tkdownto, @@ -486,6 +487,7 @@ const 'constref', 'constructor', 'destructor', + 'dispinterface', 'div', 'do', 'downto', diff --git a/packages/fcl-passrc/tests/tcbaseparser.pas b/packages/fcl-passrc/tests/tcbaseparser.pas index ba9a688862..0691933afd 100644 --- a/packages/fcl-passrc/tests/tcbaseparser.pas +++ b/packages/fcl-passrc/tests/tcbaseparser.pas @@ -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, diff --git a/packages/fcl-passrc/tests/tcclasstype.pas b/packages/fcl-passrc/tests/tcclasstype.pas index 9676ed3421..1f9a0ead62 100644 --- a/packages/fcl-passrc/tests/tcclasstype.pas +++ b/packages/fcl-passrc/tests/tcclasstype.pas @@ -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('',''); diff --git a/packages/fcl-passrc/tests/tcscanner.pas b/packages/fcl-passrc/tests/tcscanner.pas index 8b4befa739..9f457e4b83 100644 --- a/packages/fcl-passrc/tests/tcscanner.pas +++ b/packages/fcl-passrc/tests/tcscanner.pas @@ -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;