fcl-passrc: added modeswitch ignoreinterfaces, typecast enum to integer

git-svn-id: trunk@37335 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1387,6 +1387,7 @@ type
     function GetSmallestIntegerBaseType(MinVal, MaxVal: MaxPrecInt): TResolverBaseType;
     function GetCombinedChar(const Char1, Char2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
     function GetCombinedString(const Str1, Str2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
+    function IsElementSkipped(El: TPasElement): boolean; virtual;
   public
     // options
     property Options: TPasResolverOptions read FOptions write FOptions;
@@ -3457,7 +3458,10 @@ procedure TPasResolver.FinishConstDef(El: TPasConst);
 begin
   ResolveExpr(El.Expr,rraRead);
   if El.VarType<>nil then
-    CheckAssignCompatibility(El,El.Expr,true)
+    begin
+    CheckAssignCompatibility(El,El.Expr,true);
+    EmitTypeHints(El,El.VarType);
+    end
   else
     Eval(El.Expr,[refConst])
 end;
@@ -3610,6 +3614,9 @@ begin
     if not IsValidIdent(ProcName) then
       RaiseNotYetImplemented(20160922163407,El);
 
+    if El is TPasFunctionType then
+      EmitTypeHints(TPasFunctionType(El).ResultEl,TPasFunctionType(El).ResultEl.ResultType);
+
     if Proc.LibraryExpr<>nil then
       ResolveExpr(Proc.LibraryExpr,rraRead);
     if Proc.LibrarySymbolName<>nil then
@@ -4405,7 +4412,12 @@ begin
   if aClass.IsForward then
     exit;
   if aClass.ObjKind<>okClass then
+    begin
+    if (aClass.ObjKind=okInterface)
+        and (msIgnoreInterfaces in CurrentParser.CurrentModeswitches) then
+      exit;
     RaiseNotYetImplemented(20161010174638,aClass,'Kind='+ObjKindNames[aClass.ObjKind]);
+    end;
 
   IsSealed:=false;
   for i:=0 to aClass.Modifiers.Count-1 do
@@ -4443,7 +4455,10 @@ begin
   else
     begin
     AncestorEl:=TPasClassType(AncestorType);
-    EmitTypeHints(aClass,AncestorEl);
+    if AncestorEl.ObjKind<>okClass then
+      AncestorEl:=nil
+    else
+      EmitTypeHints(aClass,AncestorEl);
     end;
 
   AncestorClassScope:=nil;
@@ -4502,6 +4517,8 @@ begin
   CanonicalSelf.Visibility:=visStrictPrivate;
   CanonicalSelf.SourceFilename:=aClass.SourceFilename;
   CanonicalSelf.SourceLinenumber:=aClass.SourceLinenumber;
+
+  // ToDo: interfaces
 end;
 
 procedure TPasResolver.FinishPropertyParamAccess(Params: TParamsExpr;
@@ -4542,6 +4559,8 @@ end;
 
 function TPasResolver.EmitElementHints(PosEl, El: TPasElement): boolean;
 begin
+  if IsElementSkipped(El) then
+    RaiseMsg(20170927160030,nNotYetImplemented,sNotYetImplemented,[GetObjName(El)],PosEl);
   if El.Hints=[] then exit(false);
   Result:=true;
   if hDeprecated in El.Hints then
@@ -5923,6 +5942,7 @@ var
   Proc: TPasProcedure;
   aClassType: TPasClassType;
 begin
+  if IsElementSkipped(El) then exit;
   if El is TPasDeclarations then
     begin
     for i:=0 to TPasDeclarations(El).Declarations.Count-1 do
@@ -9262,6 +9282,8 @@ begin
   if FRootElement=nil then
     FRootElement:=Result as TPasModule;
 
+  if IsElementSkipped(El) then exit;
+
   // create scope
   if (AClass=TPasVariable)
       or (AClass=TPasConst) then
@@ -9797,6 +9819,7 @@ end;
 
 procedure TPasResolver.FinishScope(ScopeType: TPasScopeType; El: TPasElement);
 begin
+  if IsElementSkipped(El) then exit;
   case ScopeType of
   stModule: FinishModule(El as TPasModule);
   stUsesClause: FinishUsesClause;
@@ -11654,11 +11677,15 @@ end;
 
 function TPasResolver.ResolvedElIsClassInstance(
   const ResolvedEl: TPasResolverResult): boolean;
+var
+  TypeEl: TPasType;
 begin
   Result:=false;
   if ResolvedEl.BaseType<>btContext then exit;
-  if ResolvedEl.TypeEl=nil then exit;
-  if ResolvedEl.TypeEl.ClassType<>TPasClassType then exit;
+  TypeEl:=ResolvedEl.TypeEl;
+  if TypeEl=nil then exit;
+  if TypeEl.ClassType<>TPasClassType then exit;
+  if TPasClassType(TypeEl).ObjKind<>okClass then exit;
   if (ResolvedEl.IdentEl is TPasVariable)
       or (ResolvedEl.IdentEl.ClassType=TPasArgument)
       or (ResolvedEl.IdentEl.ClassType=TPasResultElement) then
@@ -12571,7 +12598,13 @@ begin
           if FromResolved.BaseType in btAllInteger then
             Result:=cCompatible
           else if FromResolved.BaseType in btAllBooleans then
-            Result:=cCompatible;
+            Result:=cCompatible
+          else if FromResolved.BaseType=btContext then
+            begin
+            if FromResolved.TypeEl.ClassType=TPasEnumType then
+              // e.g. longint(TEnum)
+              Result:=cCompatible;
+            end;
           end
         else if ToTypeBaseType in btAllFloats then
           begin
@@ -13987,6 +14020,25 @@ begin
     Result:=btString;
 end;
 
+function TPasResolver.IsElementSkipped(El: TPasElement): boolean;
+var
+  C: TClass;
+  aClass: TPasClassType;
+begin
+  while El<>nil do
+    begin
+    C:=El.ClassType;
+    if C.ClassType=TPasClassType then
+      begin
+      aClass:=TPasClassType(El);
+      if aClass.ObjKind=okInterface then
+        exit(true);
+      end;
+    El:=El.Parent;
+    end;
+  Result:=false;
+end;
+
 function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType,
   ResolvedDestType: TPasResolverResult; ErrorEl: TPasElement): integer;
 // finds distance between classes SrcType and DestType

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -1287,6 +1287,9 @@ var
   ClassScope: TPasClassScope;
   Ref: TResolvedReference;
 begin
+  if El.ObjKind=okInterface then
+    exit;
+
   FirstTime:=true;
   case Mode of
   paumAllExports: exit;

packages/fcl-passrc/src/pscanner.pp

@@ -262,7 +262,8 @@ type
     msISOLikeIO,           { I/O as it required by an ISO compatible compiler }
     msISOLikeProgramsPara, { program parameters as it required by an ISO compatible compiler }
     msISOLikeMod,          { mod operation as it is required by an iso compatible compiler }
-    msExternalClass        { Allow external class definitions }
+    msExternalClass,       { Allow external class definitions }
+    msIgnoreInterfaces     { workaround til resolver/converter supports interfaces }
   );
   TModeSwitches = Set of TModeSwitch;
 
@@ -815,7 +816,8 @@ const
     'ISOIO',
     'ISOPROGRAMPARAS',
     'ISOMOD',
-    'EXTERNALCLASS'
+    'EXTERNALCLASS',
+    'IGNOREINTERFACES'
     );
 
   LetterSwitchNames: array['A'..'Z'] of string=(

packages/fcl-passrc/tests/tcresolver.pas

@@ -520,6 +520,12 @@ type
     Procedure TestDefaultProperty;
     Procedure TestMissingDefaultProperty;
 
+    // class interfaces
+    Procedure TestIgnoreInterfaces;
+    Procedure TestInterfaceVarFail;
+    Procedure TestInterfaceArgFail;
+    Procedure TestInterfaceFunctionResultFail;
+
     // with
     Procedure TestWithBlock1;
     Procedure TestWithBlock2;
@@ -738,9 +744,9 @@ begin
       aRow:=E.Row;
       aCol:=E.Column;
       WriteSources(aFilename,aRow,aCol);
-      writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message
-        +' Scanner at'
-        +' at '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')'
+      writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message,
+        ' Scanner at'
+        +' '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')'
         +' Line="'+Scanner.CurLine+'"');
       Fail(E.Message);
       end;
@@ -2636,6 +2642,7 @@ begin
   Add('var');
   Add('  {#f}{=TFlag}f: TFlag;');
   Add('  {#v}{=TFlag}v: TFlag = Green;');
+  Add('  {#i}i: longint;');
   Add('begin');
   Add('  {@f}f:={@Red}Red;');
   Add('  {@f}f:={@v}v;');
@@ -2648,6 +2655,8 @@ begin
   Add('  if {@f}f<>{@v}v then ;');
   Add('  if ord({@f}f)<>ord({@Red}Red) then ;');
   Add('  {@f}f:={@TFlag}TFlag.{@Red}Red;');
+  Add('  {@f}f:={@TFlag}TFlag({@i}i);');
+  Add('  {@i}i:=longint({@f}f);');
   ParseProgram;
 end;
 
@@ -8336,6 +8345,77 @@ begin
     nIllegalQualifier);
 end;
 
+procedure TTestResolver.TestIgnoreInterfaces;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch ignoreinterfaces}',
+  'type',
+  '  TGUID = record end;',
+  '  IUnknown = interface;',
+  '  IUnknown = interface',
+  '    [''{00000000-0000-0000-C000-000000000046}'']',
+  '    function QueryInterface(const iid : tguid;out obj) : longint;',
+  '    function _AddRef : longint; cdecl;',
+  '    function _Release : longint; stdcall;',
+  '  end;',
+  '  IInterface = IUnknown;',
+  '  TObject = class',
+  '    ClassName: string;',
+  '  end;',
+  '  TInterfacedObject = class(TObject,IUnknown)',
+  '    RefCount : longint;',
+  '  end;',
+  'var i: TInterfacedObject;',
+  'begin',
+  '  i.ClassName:=''a'';',
+  '  i.RefCount:=3;',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestInterfaceVarFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch ignoreinterfaces}',
+  'type',
+  '  IUnknown = interface',
+  '  end;',
+  'var i: IUnknown;',
+  'begin',
+  '']);
+  CheckResolverException('not yet implemented: IUnknown:TPasClassType',nNotYetImplemented);
+end;
+
+procedure TTestResolver.TestInterfaceArgFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch ignoreinterfaces}',
+  'type',
+  '  IUnknown = interface',
+  '  end;',
+  'procedure DoIt(i: IUnknown); begin end;',
+  'begin',
+  '']);
+  CheckResolverException('not yet implemented: IUnknown:TPasClassType',nNotYetImplemented);
+end;
+
+procedure TTestResolver.TestInterfaceFunctionResultFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch ignoreinterfaces}',
+  'type',
+  '  IUnknown = interface',
+  '  end;',
+  'function DoIt: IUnknown; begin end;',
+  'begin',
+  '']);
+  CheckResolverException('not yet implemented: IUnknown:TPasClassType',nNotYetImplemented);
+end;
+
 procedure TTestResolver.TestPropertyAssign;
 begin
   StartProgram(false);

packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -72,6 +72,7 @@ type
     procedure TestM_Class_PropertyOverride;
     procedure TestM_Class_MethodOverride;
     procedure TestM_Class_MethodOverride2;
+    procedure TestM_ClassInterface_Ignore;
     procedure TestM_TryExceptStatement;
 
     // single module hints
@@ -828,6 +829,35 @@ begin
   AnalyzeProgram;
 end;
 
+procedure TTestUseAnalyzer.TestM_ClassInterface_Ignore;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch ignoreinterfaces}',
+  'type',
+  '  TGUID = record end;',
+  '  IUnknown = interface;',
+  '  IUnknown = interface',
+  '    [''{00000000-0000-0000-C000-000000000046}'']',
+  '    function QueryInterface(const iid : tguid;out obj) : longint;',
+  '    function _AddRef : longint; cdecl;',
+  '    function _Release : longint; stdcall;',
+  '  end;',
+  '  IInterface = IUnknown;',
+  '  TObject = class',
+  '    ClassName: string;',
+  '  end;',
+  '  TInterfacedObject = class(TObject,IUnknown)',
+  '    RefCount : longint;',
+  '  end;',
+  'var i: TInterfacedObject;',
+  'begin',
+  '  i.ClassName:=''a'';',
+  '  i.RefCount:=3;',
+  '']);
+  AnalyzeProgram;
+end;
+
 procedure TTestUseAnalyzer.TestM_TryExceptStatement;
 begin
   StartProgram(false);