* Support for DispInterface and DispID (bug ID 30716)

git-svn-id: trunk@34754 -

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;
 

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

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

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,

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('','');

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;