diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 249dfbc46f..38a12d472c 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/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 diff --git a/packages/fcl-passrc/src/pasuseanalyzer.pas b/packages/fcl-passrc/src/pasuseanalyzer.pas index 3ab174bca6..cf188183f6 100644 --- a/packages/fcl-passrc/src/pasuseanalyzer.pas +++ b/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; diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index cc86776fcd..4d2a758ed6 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/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=( diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index fd5897f8e9..c800ad4bf1 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/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); diff --git a/packages/fcl-passrc/tests/tcuseanalyzer.pas b/packages/fcl-passrc/tests/tcuseanalyzer.pas index ae33c69b66..d4788e5b9b 100644 --- a/packages/fcl-passrc/tests/tcuseanalyzer.pas +++ b/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);