From 624549ae349b86ead5a9c04c383632a4865d3ef0 Mon Sep 17 00:00:00 2001
From: Mattias Gaertner <nc-gaertnma@netcologne.de>
Date: Sat, 2 Mar 2019 15:08:57 +0000
Subject: [PATCH] fcl-passrc: type helper for class/interface

git-svn-id: trunk@41557 -
---
 packages/fcl-passrc/src/pasresolver.pp   | 23 ++++++---
 packages/fcl-passrc/tests/tcresolver.pas | 62 ++++++++++++++++++++++--
 2 files changed, 74 insertions(+), 11 deletions(-)

diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp
index 6fd12a1d40..9f1037503d 100644
--- a/packages/fcl-passrc/src/pasresolver.pp
+++ b/packages/fcl-passrc/src/pasresolver.pp
@@ -5846,6 +5846,7 @@ var
   ptm: TProcTypeModifier;
   ObjKind: TPasObjKind;
   ParentBody: TProcedureBody;
+  HelperForType: TPasType;
 begin
   if El.Parent is TPasProcedure then
     Proc:=TPasProcedure(El.Parent)
@@ -5940,19 +5941,28 @@ begin
         {if msDelphi in CurrentParser.CurrentModeswitches then
           begin
           // Delphi allows virtual/override in class helpers
-          // But this works differently to normal virtual/override and
-          // requires helpers to be TInterfacedObject
+          // But using them crashes in Delphi 10.3
+          // -> do not support them
           end
         }
         if Proc.IsVirtual then
           RaiseMsg(20190116215823,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'virtual'],Proc);
         if Proc.IsOverride then
           RaiseMsg(20190116215825,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'override'],Proc);
-        if (ObjKind<>okClassHelper) and IsClassMethod(Proc) and not IsClassConDestructor then
+        HelperForType:=ResolveAliasType(TPasClassType(Proc.Parent).HelperForType);
+        if (not Proc.IsStatic) and IsClassMethod(Proc) and not IsClassConDestructor then
           begin
-          if not Proc.IsStatic then
+          // non static class methods require a class
+          if (not (HelperForType.ClassType=TPasClassType))
+              or (TPasClassType(HelperForType).ObjKind<>okClass) then
             RaiseMsg(20190201153831,nClassMethodsMustBeStaticInX,sClassMethodsMustBeStaticInX,[ObjKindNames[ObjKind]],Proc);
           end;
+        if Proc.ClassType=TPasDestructor then
+          RaiseMsg(20190302151019,nXIsNotSupported,sXIsNotSupported,['destructor'],Proc);
+        if (Proc.ClassType=TPasConstructor)
+            and (HelperForType.ClassType=TPasClassType)
+            and (TPasClassType(HelperForType).ObjKind<>okClass) then
+          RaiseMsg(20190302151514,nXIsNotSupported,sXIsNotSupported,['constructor'],Proc);
         end;
       end;
       if Proc.IsAbstract then
@@ -6345,7 +6355,8 @@ begin
         SelfType:=TPasClassType(SelfType).HelperForType;
         end;
       LoSelfType:=ResolveAliasType(SelfType);
-      if LoSelfType is TPasClassType then
+      if (LoSelfType is TPasClassType)
+          and (TPasClassType(LoSelfType).ObjKind=okClass) then
         SelfArg.Access:=argConst
       else
         SelfArg.Access:=argVar;
@@ -7234,7 +7245,7 @@ begin
       else if ((HelperForType.ClassType=TPasUnresolvedSymbolRef)
           and (HelperForType.CustomData is TResElDataBaseType)) then
       else if (HelperForType.ClassType=TPasClassType)
-          and (TPasClassType(HelperForType).ObjKind=okClass) then
+          and (TPasClassType(HelperForType).ObjKind in [okClass,okInterface]) then
         begin
         if TPasClassType(HelperForType).IsForward then
           RaiseMsg(20190116200940,nTypeXIsNotYetCompletelyDefined,
diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas
index ca5bcf88ae..9c19725b07 100644
--- a/packages/fcl-passrc/tests/tcresolver.pas
+++ b/packages/fcl-passrc/tests/tcresolver.pas
@@ -932,7 +932,8 @@ type
     Procedure TestTypeHelper_Boolean;
     Procedure TestTypeHelper_Double;
     Procedure TestTypeHelper_Constructor_NewInstance;
-    Procedure TestTypeHelper_InterfaceFail;
+    Procedure TestTypeHelper_Interface;
+    Procedure TestTypeHelper_Interface_ConstructorFail;
 
     // attributes
     Procedure TestAttributes_Globals;
@@ -17593,18 +17594,69 @@ begin
     end;
 end;
 
-procedure TTestResolver.TestTypeHelper_InterfaceFail;
+procedure TTestResolver.TestTypeHelper_Interface;
 begin
   StartProgram(false);
   Add([
   '{$modeswitch typehelpers}',
   'type',
-  '  IUnknown = interface end;',
-  '  THelper = type helper for IUnknown',
+  '  IUnknown = interface',
+  '    function GetSizes(Index: word): word;',
+  '    procedure SetSizes(Index: word; value: word);',
   '  end;',
+  '  TObject = class(IUnknown)',
+  '    function GetSizes(Index: word): word; virtual; abstract;',
+  '    procedure SetSizes(Index: word; value: word); virtual; abstract;',
+  '  end;',
+  '  THelper = type helper for IUnknown',
+  '    procedure Fly;',
+  '    class procedure Run; static;',
+  '    property Sizes[Index: word]: word read GetSizes write SetSizes; default;',
+  '  end;',
+  'var',
+  '  i: IUnknown;',
+  '  o: TObject;',
+  'procedure THelper.Fly;',
+  'begin',
+  '  i:=Self;',
+  '  o:=Self as TObject;',
+  '  Self:=nil;',
+  '  Self:=i;',
+  '  Self:=o;',
+  'end;',
+  'class procedure THelper.Run;',
+  'begin',
+  'end;',
+  'begin',
+  '  i.Fly;',
+  '  i.Fly();',
+  '  i.Run;',
+  '  i.Run();',
+  '  i.Sizes[3]:=i.Sizes[4];',
+  '  i[5]:=i[6];',
+  '  IUnknown.Run;',
+  '  IUnknown.Run();',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestTypeHelper_Interface_ConstructorFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch typehelpers}',
+  'type',
+  '  IUnknown = interface',
+  '  end;',
+  '  THelper = type helper for IUnknown',
+  '    constructor Fly;',
+  '  end;',
+  'constructor THelper.Fly;',
+  'begin',
+  'end;',
   'begin',
   '']);
-  CheckResolverException('Type "IUnknown" cannot be extended by a type helper',nTypeXCannotBeExtendedByATypeHelper);
+  CheckResolverException('constructor is not supported',nXIsNotSupported);
 end;
 
 procedure TTestResolver.TestAttributes_Globals;