From e32782f5b3abb35e13ae23f17b9c5d2021c42c68 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sun, 16 Apr 2017 19:09:47 +0000 Subject: [PATCH] fcl-passrc: resolver: typecast procvar and pointer git-svn-id: trunk@35808 - --- packages/fcl-passrc/src/pasresolver.pp | 313 ++++++++++++++------ packages/fcl-passrc/tests/tcresolver.pas | 106 ++++++- packages/fcl-passrc/tests/tcuseanalyzer.pas | 22 ++ 3 files changed, 349 insertions(+), 92 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index c181c8da42..bbce97d9c3 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -131,6 +131,8 @@ Works: - built-in functions pred, succ for range type and enums - untyped parameters - built-in procedure str(const boolean|integer|enumvalue|classinstance,var s: string) +- pointer TPasPointerType + - nil, assigned(), typecast, class, classref, dynarray, procvar ToDo: - fix slow lookup declaration proc in PParser @@ -141,7 +143,6 @@ ToDo: - nested types - check if constant is longint or int64 - for..in..do -- pointer TPasPointerType - records - TPasRecordType, - const TRecordValues - function default(record type): record @@ -253,6 +254,7 @@ const nSymbolCannotBePublished = 3053; nCannotTypecastAType = 3054; nTypeIdentifierExpected = 3055; + nCannotNestAnonymousX = 3056; // resourcestring patterns of messages resourcestring @@ -311,6 +313,7 @@ resourcestring sSymbolCannotBePublished = 'Symbol cannot be published'; sCannotTypecastAType = 'Cannot type cast a type'; sTypeIdentifierExpected = 'Type identifier expected'; + sCannotNestAnonymousX = 'Cannot nest anonymous %s'; type TResolverBaseType = ( @@ -964,7 +967,8 @@ type proClassOfIs, // class-of supports is and as operator proExtClassInstanceNoTypeMembers, // class members of external class cannot be accessed by instance proOpenAsDynArrays, // open arrays work like dynamic arrays - proProcTypeWithoutIsNested // proc types can use nested procs without 'is nested' + proProcTypeWithoutIsNested, // proc types can use nested procs without 'is nested' + proMethodAddrAsPointer // can assign @method to a pointer ); TPasResolverOptions = set of TPasResolverOption; @@ -976,7 +980,7 @@ type TResolveDataListKind = (lkBuiltIn,lkModule); procedure ClearResolveDataList(Kind: TResolveDataListKind); private - FAnonymousEnumtypePostfix: String; + FAnonymousElTypePostfix: String; FBaseTypes: array[TResolverBaseType] of TPasUnresolvedSymbolRef; FBaseTypeStringIndex: TResolverBaseType; FDefaultScope: TPasDefaultScope; @@ -1090,6 +1094,7 @@ type procedure FinishTypeDef(El: TPasType); virtual; procedure FinishEnumType(El: TPasEnumType); virtual; procedure FinishSetType(El: TPasSetType); virtual; + procedure FinishSubElementType(Parent, El: TPasElement); virtual; procedure FinishRangeType(El: TPasRangeType); virtual; procedure FinishRecordType(El: TPasRecordType); virtual; procedure FinishClassType(El: TPasClassType); virtual; @@ -1411,8 +1416,8 @@ type property Options: TPasResolverOptions read FOptions write FOptions; property ScopeClass_Class: TPasClassScopeClass read FScopeClass_Class write FScopeClass_Class; property ScopeClass_WithExpr: TPasWithExprScopeClass read FScopeClass_WithExpr write FScopeClass_WithExpr; - property AnonymousEnumtypePostfix: String read FAnonymousEnumtypePostfix - write FAnonymousEnumtypePostfix; // default empty, if set, anonymous enumtypes are named SetName+Postfix and add to declarations + property AnonymousElTypePostfix: String read FAnonymousElTypePostfix + write FAnonymousElTypePostfix; // default empty, if set, anonymous element types are named ArrayName+Postfix and added to declarations end; function GetObjName(o: TObject): string; @@ -1421,6 +1426,7 @@ function GetTypeDesc(aType: TPasType; AddPath: boolean = false): string; function GetTreeDesc(El: TPasElement; Indent: integer = 0): string; function GetResolverResultDesc(const T: TPasResolverResult): string; function GetResolverResultDescription(const T: TPasResolverResult; OnlyType: boolean = false): string; +function GetResolverResultDbg(const T: TPasResolverResult): string; function ResolverResultFlagsToStr(const Flags: TPasResolverResultFlags): string; procedure SetResolverIdentifier(out ResolvedType: TPasResolverResult; BaseType: TResolverBaseType; IdentEl: TPasElement; @@ -1482,9 +1488,9 @@ begin Result:=Result+')'; end; if ProcType.IsOfObject then - Result:=Result+' of object'; + Result:=Result+' '+ProcTypeModifiers[ptmOfObject]; if ProcType.IsNested then - Result:=Result+' is nested'; + Result:=Result+' '+ProcTypeModifiers[ptmIsNested]; if cCallingConventions[ProcType.CallingConvention]<>'' then Result:=Result+';'+cCallingConventions[ProcType.CallingConvention]; end; @@ -1638,9 +1644,9 @@ begin if El is TPasFunction then Result:=Result+':'+GetTreeDesc(TPasFunctionType(TPasFunction(El).ProcType).ResultEl,Indent); if TPasProcedureType(El).IsOfObject then - Result:=Result+' of object'; + Result:=Result+' '+ProcTypeModifiers[ptmOfObject]; if TPasProcedureType(El).IsNested then - Result:=Result+' is nested'; + Result:=Result+' '+ProcTypeModifiers[ptmIsNested]; if cCallingConventions[TPasProcedureType(El).CallingConvention]<>'' then Result:=Result+'; '+cCallingConventions[TPasProcedureType(El).CallingConvention]; end @@ -1756,6 +1762,18 @@ begin Result:=T.IdentEl.Name+':'+Result; end; +function GetResolverResultDbg(const T: TPasResolverResult): string; +begin + Result:='bt='+BaseTypeNames[T.BaseType]; + if T.SubType<>btNone then + Result:=Result+' Sub='+BaseTypeNames[T.SubType]; + Result:=Result + +' Ident='+GetObjName(T.IdentEl) + +' Type='+GetObjName(T.TypeEl) + +' Expr='+GetObjName(T.ExprEl) + +' Flags='+ResolverResultFlagsToStr(T.Flags); +end; + function ResolverResultFlagsToStr(const Flags: TPasResolverResultFlags): string; var f: TPasResolverResultFlag; @@ -2717,9 +2735,11 @@ begin else if (C=TPasClassType) or (C=TPasClassOfType) or (C=TPasEnumType) + or (C=TPasProcedureType) + or (C=TPasFunctionType) or (C=TPasArrayType) then begin - // type cast to a class, class-of, enum, or array + // type cast to user type Abort:=true; // can't be overloaded if Data^.Found<>nil then exit; Distance:=CheckTypeCast(TPasType(El),Data^.Params,false); @@ -3149,41 +3169,12 @@ var RangeExpr: TBinaryExpr; C: TClass; EnumType: TPasType; - - procedure CheckAnonymousElType; - var - Decl: TPasDeclarations; - EnumScope: TPasEnumTypeScope; - begin - if (EnumType.Name<>'') or (AnonymousEnumtypePostfix='') then exit; - if El.Name='' then - RaiseNotYetImplemented(20170415165455,EnumType); - // give anonymous enumtype a name - EnumType.Name:=El.Name+AnonymousEnumtypePostfix; - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.FinishSetType set="',GetObjName(El),'" named anonymous enumtype "',GetObjName(EnumType),'"'); - {$ENDIF} - if not (El.Parent is TPasDeclarations) then - RaiseNotYetImplemented(20170415161624,EnumType,GetObjName(El.Parent)); - Decl:=TPasDeclarations(El.Parent); - Decl.Declarations.Add(EnumType); - EnumType.AddRef; - EnumType.Parent:=Decl; - Decl.Types.Add(EnumType); - if EnumType is TPasEnumType then - begin - EnumScope:=TPasEnumTypeScope(EnumType.CustomData); - ReleaseAndNil(TPasElement(EnumScope.CanonicalSet)); - EnumScope.CanonicalSet:=El; - end; - end; - begin EnumType:=El.EnumType; C:=EnumType.ClassType; if C=TPasEnumType then begin - CheckAnonymousElType; + FinishSubElementType(El,EnumType); exit; end else if C=TPasRangeType then @@ -3191,7 +3182,7 @@ begin RangeExpr:=TPasRangeType(EnumType).RangeExpr; if RangeExpr.Parent=El then CheckRangeExpr(RangeExpr.left,RangeExpr.right,StartResolved,EndResolved); - CheckAnonymousElType; + FinishSubElementType(El,EnumType); exit; end else if C=TPasUnresolvedSymbolRef then @@ -3207,6 +3198,37 @@ begin RaiseXExpectedButYFound(20170216151557,'enum type',EnumType.ElementTypeName,EnumType); end; +procedure TPasResolver.FinishSubElementType(Parent, El: TPasElement); +var + Decl: TPasDeclarations; + EnumScope: TPasEnumTypeScope; +begin + if (El.Name<>'') or (AnonymousElTypePostfix='') then exit; + if Parent.Name='' then + RaiseMsg(20170415165455,nCannotNestAnonymousX,sCannotNestAnonymousX,[El.ElementTypeName],El); + if not (Parent.Parent is TPasDeclarations) then + RaiseMsg(20170416094735,nCannotNestAnonymousX,sCannotNestAnonymousX,[El.ElementTypeName],El); + // give anonymous sub type a name + El.Name:=Parent.Name+AnonymousElTypePostfix; + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishSubElementType parent="',GetObjName(Parent),'" named anonymous type "',GetObjName(El),'"'); + {$ENDIF} + Decl:=TPasDeclarations(Parent.Parent); + Decl.Declarations.Add(El); + El.AddRef; + El.Parent:=Decl; + Decl.Types.Add(El); + if (El.ClassType=TPasEnumType) and (Parent.ClassType=TPasSetType) then + begin + EnumScope:=TPasEnumTypeScope(El.CustomData); + if EnumScope.CanonicalSet<>Parent then + begin + ReleaseAndNil(TPasElement(EnumScope.CanonicalSet)); + EnumScope.CanonicalSet:=TPasSetType(Parent); + end; + end; +end; + procedure TPasResolver.FinishRangeType(El: TPasRangeType); var StartResolved, EndResolved: TPasResolverResult; @@ -3258,6 +3280,7 @@ begin else RaiseXExpectedButYFound(20170216151609,'range',RangeResolved.IdentEl.ElementTypeName,Expr); end; + FinishSubElementType(El,El.ElType); end; procedure TPasResolver.FinishConstDef(El: TPasConst); @@ -5013,12 +5036,12 @@ begin begin // FoundEl one element, but it was incompatible => raise error {$IFDEF VerbosePasResolver} - writeln('TPasResolver.ResolveParamsExpr found one element, but it was incompatible => check again to raise error'); + writeln('TPasResolver.ResolveFuncParamsExpr found one element, but it was incompatible => check again to raise error. Found=',GetObjName(FindCallData.Found)); {$ENDIF} if FindCallData.Found is TPasProcedure then CheckCallProcCompatibility(TPasProcedure(FindCallData.Found).ProcType,Params,true) else if FindCallData.Found is TPasProcedureType then - CheckCallProcCompatibility(TPasProcedureType(FindCallData.Found),Params,true) + CheckTypeCast(TPasProcedureType(FindCallData.Found),Params,true) else if FindCallData.Found.ClassType=TPasUnresolvedSymbolRef then begin if FindCallData.Found.CustomData is TResElDataBuiltInProc then @@ -5059,7 +5082,7 @@ begin // ToDo: create a hint for each candidate El:=TPasElement(FindCallData.List[i]); {$IFDEF VerbosePasResolver} - writeln('TPasResolver.ResolveParamsExpr Overload Candidate: ',GetElementSourcePosStr(El),' ',GetTreeDesc(El)); + writeln('TPasResolver.ResolveFuncParamsExpr Overload Candidate: ',GetElementSourcePosStr(El),' ',GetTreeDesc(El)); {$ENDIF} Msg:=Msg+', '; Msg:=Msg+GetElementSourcePosStr(El); @@ -5094,6 +5117,10 @@ begin if (C=TPasClassType) or (C=TPasClassOfType) or (C=TPasEnumType) + or (C=TPasSetType) + or (C=TPasPointerType) + or (C=TPasProcedureType) + or (C=TPasFunctionType) or (C=TPasArrayType) then begin // type cast @@ -5131,11 +5158,12 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.ResolveFuncParamsExpr FoundEl=',GetObjName(FoundEl),' CustomData=',GetObjName(FoundEl.CustomData)); {$ENDIF} - RaiseNotYetImplemented(20170306121908,Params); + RaiseMsg(20170306121908,nIllegalExpression,sIllegalExpression,[],Params); end; end else begin + // FoundEl is not a type, maybe a var ComputeElement(FoundEl,ResolvedEl,[rcNoImplicitProc]); if ResolvedEl.TypeEl is TPasProcedureType then begin @@ -5145,7 +5173,7 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.ResolveFuncParamsExpr FoundEl=',GetObjName(FoundEl),' CustomData=',GetObjName(FoundEl.CustomData),' Resolvedel=',GetResolverResultDesc(ResolvedEl)); {$ENDIF} - RaiseNotYetImplemented(20170306104301,Params); + RaiseMsg(20170306104301,nIllegalExpression,sIllegalExpression,[],Params); end; end else if Value.ClassType=TParamsExpr then @@ -5159,7 +5187,7 @@ begin if IsProcedureType(ResolvedEl,true) then begin CheckCallProcCompatibility(TPasProcedureType(ResolvedEl.TypeEl),Params,true); - CreateReference(ResolvedEl.TypeEl,Value,Access); + CreateReference(TPasProcedureType(ResolvedEl.TypeEl),Value,Access); exit; end end; @@ -5354,7 +5382,7 @@ end; procedure TPasResolver.AccessExpr(Expr: TPasExpr; Access: TResolvedRefAccess); -// called after a call overload was found for each element +// called after a call target was found, called for each element // to set the rraParamToUnknownProc to Access var Ref: TResolvedReference; @@ -6417,16 +6445,39 @@ begin end else if ResolvedEl.TypeEl is TPasProcedureType then begin - if rcConstant in Flags then - RaiseConstantExprExp(20170216152639,Params); - if ResolvedEl.TypeEl is TPasFunctionType then - // function call => return result - ComputeElement(TPasFunctionType(ResolvedEl.TypeEl).ResultEl, - ResolvedEl,Flags+[rcNoImplicitProc],StartEl) + if Params.Value is TParamsExpr then + begin + // e.g. Name()() or Name[]() + Include(ResolvedEl.Flags,rrfReadable); + end; + if rrfReadable in ResolvedEl.Flags then + begin + // call procvar + if rcConstant in Flags then + RaiseConstantExprExp(20170216152639,Params); + if ResolvedEl.TypeEl is TPasFunctionType then + // function call => return result + ComputeElement(TPasFunctionType(ResolvedEl.TypeEl).ResultEl, + ResolvedEl,Flags+[rcNoImplicitProc],StartEl) + else + // procedure call, result is neither readable nor writable + SetResolverTypeExpr(ResolvedEl,btProc,TPasProcedureType(ResolvedEl.TypeEl),[]); + Include(ResolvedEl.Flags,rrfCanBeStatement); + end else - // procedure call, result is neither readable nor writable - SetResolverTypeExpr(ResolvedEl,btProc,TPasProcedureType(ResolvedEl.TypeEl),[]); - Include(ResolvedEl.Flags,rrfCanBeStatement); + begin + // typecast proctype + if length(Params.Params)<>1 then + begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ComputeFuncParams DeclEl=',GetObjName(DeclEl),' ',GetResolverResultDbg(ResolvedEl)); + {$ENDIF} + RaiseMsg(20170416185211,nWrongNumberOfParametersForTypeCast, + sWrongNumberOfParametersForTypeCast,[ResolvedEl.TypeEl.Name],Params); + end; + SetResolverValueExpr(ResolvedEl,btContext,TPasProcedureType(ResolvedEl.TypeEl), + Params.Params[0],[rrfReadable]); + end; end else if (DeclEl is TPasType) then begin @@ -9018,15 +9069,15 @@ begin exit; end; if Proc1.IsNested<>Proc2.IsNested then - exit(ModifierError('is nested')); + exit(ModifierError(ProcTypeModifiers[ptmIsNested])); if Proc1.IsOfObject<>Proc2.IsOfObject then begin if (proProcTypeWithoutIsNested in Options) then - exit(ModifierError('of object')) + exit(ModifierError(ProcTypeModifiers[ptmOfObject])) else if Proc1.IsNested then // "is nested" can handle both, proc and method. else - exit(ModifierError('of object')) + exit(ModifierError(ProcTypeModifiers[ptmOfObject])) end; if Proc1.CallingConvention<>Proc2.CallingConvention then begin @@ -9234,7 +9285,7 @@ begin [],ErrorEl); exit(cIncompatible); end - else if LHS.BaseType in [btRange,btSet,btModule,btArray] then + else if LHS.BaseType in [btRange,btSet,btModule,btArray,btProc] then begin if RaiseOnIncompatible then RaiseMsg(20170216152432,nIllegalExpression,sIllegalExpression,[],ErrorEl); @@ -9300,8 +9351,10 @@ begin Result:=cExact+1 // any pointer can take a btPointer else if IsSameType(LHS.TypeEl,RHS.TypeEl) then Result:=cExact // pointer of same type - else if (LHS.TypeEl<>nil) and (RHS.TypeEl<>nil) then - Result:=CheckAssignCompatibility(LHS.TypeEl,RHS.TypeEl,RaiseOnIncompatible); + else if (LHS.TypeEl.ClassType=TPasPointerType) + and (RHS.TypeEl.ClassType=TPasPointerType) then + Result:=CheckAssignCompatibility(TPasPointerType(LHS.TypeEl).DestType, + TPasPointerType(RHS.TypeEl).DestType,RaiseOnIncompatible); end else if IsBaseType(LHS.TypeEl,btPointer) then begin @@ -9316,7 +9369,9 @@ begin begin if IsDynArray(RHS.TypeEl) then Result:=cExact; - end; + end + else if (C=TPasProcedureType) or (C=TPasFunctionType) then + Result:=cExact+1; end; end; end @@ -9713,7 +9768,7 @@ begin if not ResolvedElCanBeVarParam(ExprResolved) then begin {$IFDEF VerbosePasResolver} - writeln('TPasResolver.CheckParamCompatibility NeedWritable: Identifier=',GetObjName(ExprResolved.IdentEl),' Type=',GetObjName(ExprResolved.TypeEl),' Expr=',GetObjName(ExprResolved.ExprEl),' Flags=',ResolverResultFlagsToStr(ExprResolved.Flags)); + writeln('TPasResolver.CheckParamCompatibility NeedWritable: ',GetResolverResultDbg(ExprResolved)); {$ENDIF} if RaiseOnError then RaiseMsg(20170216152450,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr); @@ -10152,8 +10207,8 @@ begin exit(cIncompatible); end; Param:=Params.Params[0]; - ComputeElement(Param,ParamResolved,[]); - ComputeElement(El,ResolvedEl,[]); + ComputeElement(Param,ParamResolved,[rcNoImplicitProc]); + ComputeElement(El,ResolvedEl,[rcNoImplicitProc]); Result:=CheckTypeCastRes(ParamResolved,ResolvedEl,Param,RaiseOnError); end; @@ -10164,9 +10219,10 @@ var ToTypeEl, ToClassType, FromClassType: TPasType; ToTypeBaseType: TResolverBaseType; C: TClass; + ToProcType, FromProcType: TPasProcedureType; begin Result:=cIncompatible; - ToTypeEl:=ToResolved.TypeEl; + ToTypeEl:=ResolveAliasType(ToResolved.TypeEl); if (ToTypeEl<>nil) and (rrfReadable in FromResolved.Flags) then begin @@ -10217,7 +10273,30 @@ begin or (C=TPasClassOfType) or (C=TPasPointerType) or ((C=TPasArrayType) and IsDynArray(FromResolved.TypeEl)) then - Result:=cExact; + Result:=cExact + else if (C=TPasProcedureType) or (C=TPasFunctionType) then + begin + // from procvar to pointer + FromProcType:=TPasProcedureType(FromResolved.TypeEl); + if FromProcType.IsOfObject then + begin + if proMethodAddrAsPointer in Options then + Result:=cExact+1 + else if RaiseOnError then + RaiseMsg(20170416183615,nIllegalTypeConversionTo,sIllegalTypeConversionTo, + [FromProcType.ElementTypeName+' '+ProcTypeModifiers[ptmOfObject], + BaseTypeNames[btPointer]],ErrorEl); + end + else if FromProcType.IsNested then + begin + if RaiseOnError then + RaiseMsg(20170416183800,nIllegalTypeConversionTo,sIllegalTypeConversionTo, + [FromProcType.ElementTypeName+' '+ProcTypeModifiers[ptmIsNested], + BaseTypeNames[btPointer]],ErrorEl); + end + else + Result:=cExact+1; + end; end; end; end; @@ -10285,25 +10364,77 @@ begin and IsBaseType(FromResolved.TypeEl,btPointer) then Result:=cExact; // untyped pointer to dynnamic array end; + end + else if (C=TPasProcedureType) or (C=TPasFunctionType) then + begin + ToProcType:=TPasProcedureType(ToTypeEl); + if IsBaseType(FromResolved.TypeEl,btPointer) then + begin + // type cast untyped pointer value to proctype + if ToProcType.IsOfObject then + begin + if proMethodAddrAsPointer in Options then + Result:=cExact+1 + else if RaiseOnError then + RaiseMsg(20170416183940,nIllegalTypeConversionTo,sIllegalTypeConversionTo, + [BaseTypeNames[btPointer], + ToProcType.ElementTypeName+' '+ProcTypeModifiers[ptmOfObject]],ErrorEl); + end + else if ToProcType.IsNested then + begin + if RaiseOnError then + RaiseMsg(20170416184149,nIllegalTypeConversionTo,sIllegalTypeConversionTo, + [BaseTypeNames[btPointer], + ToProcType.ElementTypeName+' '+ProcTypeModifiers[ptmIsNested]],ErrorEl); + end + else + Result:=cExact+1; + end + else if FromResolved.BaseType=btContext then + begin + if FromResolved.TypeEl is TPasProcedureType then + begin + // type cast procvar to proctype + FromProcType:=TPasProcedureType(FromResolved.TypeEl); + if (FromProcType.IsOfObject<>ToProcType.IsOfObject) + and not (proMethodAddrAsPointer in Options) then + begin + if RaiseOnError then + RaiseMsg(20170416183109,nIllegalTypeConversionTo,sIllegalTypeConversionTo, + [FromProcType.ElementTypeName+BoolToStr(FromProcType.IsOfObject,' '+ProcTypeModifiers[ptmOfObject],''), + ToProcType.ElementTypeName+BoolToStr(ToProcType.IsOfObject,' '+ProcTypeModifiers[ptmOfObject],'')],ErrorEl); + end + else if FromProcType.IsNested<>ToProcType.IsNested then + begin + if RaiseOnError then + RaiseMsg(20170416183305,nIllegalTypeConversionTo,sIllegalTypeConversionTo, + [FromProcType.ElementTypeName+BoolToStr(FromProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],''), + ToProcType.ElementTypeName+BoolToStr(ToProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],'')],ErrorEl); + end + else + Result:=cExact+1; + end; + end; end; end else if ToTypeEl<>nil then begin // FromResolved is not readable - if (FromResolved.BaseType=btContext) - and (FromResolved.TypeEl.ClassType=TPasClassType) - and (FromResolved.TypeEl=FromResolved.IdentEl) - and (ToResolved.BaseType=btContext) - and (ToResolved.TypeEl.ClassType=TPasClassOfType) - and (ToResolved.TypeEl=ToResolved.IdentEl) then + if FromResolved.BaseType=btContext then begin - // for example class-of(Self) in a class function - ToClassType:=TPasClassOfType(ToTypeEl).DestType; - FromClassType:=TPasClassType(FromResolved.TypeEl); - Result:=CheckClassesAreRelated(ToClassType,FromClassType,ErrorEl); - if ResultpekFuncParams) then exit; @@ -11023,13 +11155,20 @@ begin if not (Value.CustomData is TResolvedReference) then exit; Ref:=TResolvedReference(Value.CustomData); Decl:=Ref.Declaration; - if (Decl.ClassType=TPasAliasType) or (Decl.ClassType=TPasTypeAliasType) then + C:=Decl.ClassType; + if (C=TPasAliasType) or (C=TPasTypeAliasType) then + begin Decl:=ResolveAliasType(TPasAliasType(Decl)); - if (Decl.ClassType=TPasClassType) - or (Decl.ClassType=TPasClassOfType) - or (Decl.ClassType=TPasEnumType) then - exit(true); - if (Decl.ClassType=TPasUnresolvedSymbolRef) + C:=Decl.ClassType; + end; + if (C=TPasProcedureType) + or (C=TPasFunctionType) then + exit(true) + else if (C=TPasClassType) + or (C=TPasClassOfType) + or (C=TPasEnumType) then + exit(true) + else if (C=TPasUnresolvedSymbolRef) and (Decl.CustomData is TResElDataBaseType) then exit(true); end; diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index e566a25a04..f5623089b7 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -473,6 +473,7 @@ type Procedure TestDynArrayOfLongint; Procedure TestStaticArray; Procedure TestArrayOfArray; + Procedure TestArrayOfArray_NameAnonymous; Procedure TestFunctionReturningArray; Procedure TestArray_LowHigh; Procedure TestArray_AssignSameSignatureFail; @@ -528,10 +529,14 @@ type Procedure TestProcType_AsArgOtherUnit; Procedure TestProcType_Property; Procedure TestProcType_PropertyCallWrongArgFail; + Procedure TestProcType_Typecast; // pointer Procedure TestPointer; Procedure TestPointer_AssignPointerToClassFail; + Procedure TestPointer_TypecastToMethodTypeFail; + Procedure TestPointer_TypecastFromMethodTypeFail; + Procedure TestPointer_TypecastMethod_proMethodAddrAsPointer; end; function LinesToStr(Args: array of const): string; @@ -2439,7 +2444,7 @@ end; procedure TTestResolver.TestSet_AnonymousEnumtypeName; begin - ResolverEngine.AnonymousEnumtypePostfix:='$enum'; + ResolverEngine.AnonymousElTypePostfix:='$enum'; StartProgram(false); Add('type'); Add(' TFlags = set of (red, green);'); @@ -7358,6 +7363,22 @@ begin ParseProgram; end; +procedure TTestResolver.TestArrayOfArray_NameAnonymous; +begin + ResolverEngine.AnonymousElTypePostfix:='$array'; + StartProgram(false); + Add('type'); + Add(' TArrA = array of array of longint;'); + Add('var'); + Add(' a: TArrA;'); + Add('begin'); + Add(' a[1][2]:=5;'); + Add(' a[1,2]:=5;'); + Add(' if a[2,1]=a[0,1] then ;'); + Add(' a[3][4]:=a[5,6];'); + ParseProgram; +end; + procedure TTestResolver.TestFunctionReturningArray; begin StartProgram(false); @@ -8110,7 +8131,7 @@ begin Add('var n: TNotifyEvent;'); Add('begin'); Add(' n:=@ProcA;'); - CheckResolverException('procedure type modifier "of object" mismatch', + CheckResolverException('procedure type modifier "of Object" mismatch', PasResolver.nXModifierMismatchY); end; @@ -8129,7 +8150,7 @@ begin Add(' o: TObject;'); Add('begin'); Add(' n:=@o.ProcA;'); - CheckResolverException('procedure type modifier "of object" mismatch', + CheckResolverException('procedure type modifier "of Object" mismatch', PasResolver.nXModifierMismatchY); end; @@ -8304,7 +8325,7 @@ begin Add('begin'); Add(' Button1.OnClick := App.BtnClickHandler();'); CheckResolverException( - 'Wrong number of parameters specified for call to "procedure BtnClickHandler(TObject) of object"', + 'Wrong number of parameters specified for call to "procedure BtnClickHandler(TObject) of Object"', nWrongNumberOfParametersForCallTo); end; @@ -8328,7 +8349,7 @@ begin Add('begin'); Add(' Button1.OnClick := @App.BtnClickHandler();'); CheckResolverException( - 'Wrong number of parameters specified for call to "procedure BtnClickHandler(TObject) of object"', + 'Wrong number of parameters specified for call to "procedure BtnClickHandler(TObject) of Object"', nWrongNumberOfParametersForCallTo); end; @@ -8538,6 +8559,32 @@ begin nIncompatibleTypeArgNo); end; +procedure TTestResolver.TestProcType_Typecast; +begin + StartProgram(false); + Add('type'); + Add(' TNotifyEvent = procedure(Sender: Pointer) of object;'); + Add(' TEvent = procedure of object;'); + Add(' TProcA = procedure(i: longint);'); + Add(' TFuncB = function(i, j: longint): longint;'); + Add('var'); + Add(' Notify: TNotifyEvent;'); + Add(' Event: TEvent;'); + Add(' ProcA: TProcA;'); + Add(' FuncB: TFuncB;'); + Add(' p: pointer;'); + Add('begin'); + Add(' Notify:=TNotifyEvent(Event);'); + Add(' Event:=TEvent(Event);'); + Add(' Event:=TEvent(Notify);'); + Add(' ProcA:=TProcA(FuncB);'); + Add(' FuncB:=TFuncB(FuncB);'); + Add(' FuncB:=TFuncB(ProcA);'); + Add(' ProcA:=TProcA(p);'); + Add(' FuncB:=TFuncB(p);'); + ParseProgram; +end; + procedure TTestResolver.TestPointer; begin StartProgram(false); @@ -8546,11 +8593,14 @@ begin Add(' TClass = class of TObject;'); Add(' TMyPtr = pointer;'); Add(' TArrInt = array of longint;'); + Add(' TFunc = function: longint;'); + Add('procedure DoIt; begin end;'); Add('var'); Add(' p: TMyPtr;'); Add(' Obj: TObject;'); Add(' Cl: TClass;'); Add(' a: tarrint;'); + Add(' f: TFunc;'); Add('begin'); Add(' p:=nil;'); Add(' if p=nil then;'); @@ -8559,6 +8609,9 @@ begin Add(' p:=obj;'); Add(' p:=cl;'); Add(' p:=a;'); + Add(' p:=Pointer(f);'); + Add(' p:=@DoIt;'); + Add(' p:=Pointer(@DoIt)'); Add(' obj:=TObject(p);'); Add(' cl:=TClass(p);'); Add(' a:=TArrInt(p);'); @@ -8579,6 +8632,49 @@ begin nIncompatibleTypesGotExpected); end; +procedure TTestResolver.TestPointer_TypecastToMethodTypeFail; +begin + StartProgram(false); + Add('type'); + Add(' TEvent = procedure of object;'); + Add('var'); + Add(' p: pointer;'); + Add(' e: TEvent;'); + Add('begin'); + Add(' e:=TEvent(p);'); + CheckResolverException('Illegal type conversion: "Pointer" to "procedure type of Object"', + nIllegalTypeConversionTo); +end; + +procedure TTestResolver.TestPointer_TypecastFromMethodTypeFail; +begin + StartProgram(false); + Add('type'); + Add(' TEvent = procedure of object;'); + Add('var'); + Add(' p: pointer;'); + Add(' e: TEvent;'); + Add('begin'); + Add(' p:=Pointer(e);'); + CheckResolverException('Illegal type conversion: "procedure type of Object" to "Pointer"', + nIllegalTypeConversionTo); +end; + +procedure TTestResolver.TestPointer_TypecastMethod_proMethodAddrAsPointer; +begin + ResolverEngine.Options:=ResolverEngine.Options+[proMethodAddrAsPointer]; + StartProgram(false); + Add('type'); + Add(' TEvent = procedure of object;'); + Add('var'); + Add(' p: pointer;'); + Add(' e: TEvent;'); + Add('begin'); + Add(' e:=TEvent(p);'); + Add(' p:=Pointer(e);'); + ParseProgram; +end; + initialization RegisterTests([TTestResolver]); diff --git a/packages/fcl-passrc/tests/tcuseanalyzer.pas b/packages/fcl-passrc/tests/tcuseanalyzer.pas index b5d8a4866c..3c4cad5249 100644 --- a/packages/fcl-passrc/tests/tcuseanalyzer.pas +++ b/packages/fcl-passrc/tests/tcuseanalyzer.pas @@ -79,6 +79,7 @@ type procedure TestM_Hint_UnitNotUsed_No_OnlyExternal; procedure TestM_Hint_ParameterNotUsed; procedure TestM_Hint_ParameterNotUsed_Abstract; + procedure TestM_Hint_ParameterNotUsedTypecast; procedure TestM_Hint_LocalVariableNotUsed; procedure TestM_Hint_InterfaceUnitVariableUsed; procedure TestM_Hint_ValueParameterIsAssignedButNeverUsed; @@ -900,6 +901,27 @@ begin CheckUnexpectedMessages; end; +procedure TTestUseAnalyzer.TestM_Hint_ParameterNotUsedTypecast; +begin + StartProgram(true); + Add('type'); + Add(' TObject = class end;'); + Add(' TSortCompare = function(a,b: Pointer): integer;'); + Add(' TObjCompare = function(a,b: TObject): integer;'); + Add('procedure Sort(const Compare: TSortCompare);'); + Add('begin'); + Add(' Compare(nil,nil);'); + Add('end;'); + Add('procedure DoIt(const Compare: TObjCompare);'); + Add('begin'); + Add(' Sort(TSortCompare(Compare));'); + Add('end;'); + Add('begin'); + Add(' DoIt(nil);'); + AnalyzeProgram; + CheckUnexpectedMessages; +end; + procedure TTestUseAnalyzer.TestM_Hint_LocalVariableNotUsed; begin StartProgram(true);