diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 793b0099b8..d1b41b0bef 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -563,6 +563,7 @@ type bfInsertArray, bfDeleteArray, bfTypeInfo, + bfGetTypeKind, bfAssert, bfNew, bfDispose, @@ -600,6 +601,7 @@ const 'Insert', 'Delete', 'TypeInfo', + 'GetTypeKind', 'Assert', 'New', 'Dispose', @@ -1772,6 +1774,8 @@ type function FindUsedUnitname(const aName: string; aMod: TPasModule): TPasModule; procedure FinishAssertCall(Proc: TResElDataBuiltInProc; Params: TParamsExpr); virtual; + function FindSystemIdentifier(const aUnitName, aName: string; + ErrorEl: TPasElement): TPasElement; virtual; function FindSystemClassType(const aUnitName, aClassName: string; ErrorEl: TPasElement): TPasClassType; virtual; function FindSystemClassTypeAndConstructor(const aUnitName, aClassName: string; @@ -1782,6 +1786,8 @@ type function FindTVarRec(ErrorEl: TPasElement): TPasRecordType; virtual; function GetTVarRec(El: TPasArrayType): TPasRecordType; virtual; function FindDefaultConstructor(aClass: TPasClassType): TPasConstructor; virtual; + function GetTypeInfoParamType(Param: TPasExpr; + out ParamResolved: TPasResolverResult; LoType: boolean): TPasType; virtual; protected // constant evaluation fExprEvaluator: TResExprEvaluator; @@ -2027,6 +2033,12 @@ type Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; procedure BI_TypeInfo_OnGetCallResult(Proc: TResElDataBuiltInProc; Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual; + function BI_GetTypeKind_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; + Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; + procedure BI_GetTypeKind_OnGetCallResult(Proc: TResElDataBuiltInProc; + Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual; + procedure BI_GetTypeKind_OnEval(Proc: TResElDataBuiltInProc; + Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual; function BI_Assert_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; procedure BI_Assert_OnFinishParamsExpr(Proc: TResElDataBuiltInProc; @@ -14890,13 +14902,12 @@ begin CreateReference(aConstructor,Params,rraRead); end; -function TPasResolver.FindSystemClassType(const aUnitName, aClassName: string; - ErrorEl: TPasElement): TPasClassType; +function TPasResolver.FindSystemIdentifier(const aUnitName, aName: string; + ErrorEl: TPasElement): TPasElement; var aMod, UtilsMod: TPasModule; SectionScope: TPasSectionScope; Identifier: TPasIdentifier; - El: TPasElement; begin Result:=nil; @@ -14912,17 +14923,27 @@ begin // find class in interface if UtilsMod.InterfaceSection=nil then if ErrorEl<>nil then - RaiseIdentifierNotFound(20200523224831,aUnitName+'.'+aClassName,ErrorEl) + RaiseIdentifierNotFound(20200523224831,aUnitName+'.'+aName,ErrorEl) else exit; SectionScope:=NoNil(UtilsMod.InterfaceSection.CustomData) as TPasSectionScope; - Identifier:=SectionScope.FindLocalIdentifier(aClassName); + Identifier:=SectionScope.FindLocalIdentifier(aName); if Identifier=nil then if ErrorEl<>nil then - RaiseIdentifierNotFound(20200523224841,aUnitName+'.'+aClassName,ErrorEl) + RaiseIdentifierNotFound(20200523224841,aUnitName+'.'+aName,ErrorEl) else exit; - El:=Identifier.Element; + Result:=Identifier.Element; +end; + +function TPasResolver.FindSystemClassType(const aUnitName, aClassName: string; + ErrorEl: TPasElement): TPasClassType; +var + El: TPasElement; +begin + Result:=nil; + + El:=FindSystemIdentifier(aUnitName,aClassName,ErrorEl); if not (El is TPasClassType) then if ErrorEl<>nil then RaiseXExpectedButYFound(20180119172517,'class '+aClassName,GetElementTypeName(El),ErrorEl) @@ -15128,6 +15149,37 @@ begin until false; end; +function TPasResolver.GetTypeInfoParamType(Param: TPasExpr; out + ParamResolved: TPasResolverResult; LoType: boolean): TPasType; +var + Decl: TPasElement; +begin + Result:=nil; + // check type or var + ComputeElement(Param,ParamResolved,[rcNoImplicitProc]); + Decl:=ParamResolved.IdentEl; + if Decl=nil then exit; + if Decl is TPasType then + Result:=TPasType(Decl) + else if Decl is TPasVariable then + Result:=TPasVariable(Decl).VarType + else if Decl.ClassType=TPasArgument then + Result:=TPasArgument(Decl).ArgType + else if Decl.ClassType=TPasResultElement then + Result:=TPasResultElement(Decl).ResultType + else if (Decl is TPasProcedure) + and (TPasProcedure(Decl).ProcType is TPasFunctionType) then + Result:=TPasFunctionType(TPasProcedure(Decl).ProcType).ResultEl.ResultType; + {$IFDEF VerbosePasResolver} + {AllowWriteln} + if Result=nil then + writeln('TPasResolver.GetTypeInfoParamType Decl=',GetObjName(Decl),' ParamResolved=',GetResolverResultDbg(ParamResolved)); + {AllowWriteln-} + {$ENDIF} + if LoType then + Result:=ResolveAliasType(Result); +end; + procedure TPasResolver.OnExprEvalLog(Sender: TResExprEvaluator; const id: TMaxPrecInt; MsgType: TMessageType; MsgNumber: integer; const Fmt: String; Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif}; @@ -19974,47 +20026,18 @@ function TPasResolver.BI_TypeInfo_OnGetCallCompatibility( var Params: TParamsExpr; Param: TPasExpr; - Decl: TPasElement; - ParamResolved: TPasResolverResult; aType: TPasType; + ParamResolved: TPasResolverResult; begin Result:=cIncompatible; if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then exit; Params:=TParamsExpr(Expr); - // check type or var Param:=Params.Params[0]; - ComputeElement(Param,ParamResolved,[rcNoImplicitProc]); - Decl:=ParamResolved.IdentEl; - aType:=nil; - if (Decl<>nil) then - begin - if Decl is TPasType then - aType:=TPasType(Decl) - else if Decl is TPasVariable then - aType:=TPasVariable(Decl).VarType - else if Decl.ClassType=TPasArgument then - aType:=TPasArgument(Decl).ArgType - else if Decl.ClassType=TPasResultElement then - aType:=TPasResultElement(Decl).ResultType - else if (Decl is TPasProcedure) - and (TPasProcedure(Decl).ProcType is TPasFunctionType) then - aType:=TPasFunctionType(TPasProcedure(Decl).ProcType).ResultEl.ResultType; - {$IFDEF VerbosePasResolver} - {AllowWriteln} - if aType=nil then - writeln('TPasResolver.BI_TypeInfo_OnGetCallCompatibility Decl=',GetObjName(Decl)); - {AllowWriteln-} - {$ENDIF} - end; + aType:=GetTypeInfoParamType(Param,ParamResolved,true); if aType=nil then - begin - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.BI_TypeInfo_OnGetCallCompatibility ',GetResolverResultDbg(ParamResolved)); - {$ENDIF} RaiseMsg(20170411100259,nTypeIdentifierExpected,sTypeIdentifierExpected,[],Param); - end; aType:=ResolveAliasType(aType); if not HasTypeInfo(aType) then RaiseMsg(20170413200118,nSymbolCannotBePublished,sSymbolCannotBePublished,[],Param); @@ -20031,6 +20054,138 @@ begin FBaseTypes[btPointer],FBaseTypes[btPointer],[rrfReadable]); end; +function TPasResolver.BI_GetTypeKind_OnGetCallCompatibility( + Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; +var + Params: TParamsExpr; + Param: TPasExpr; + aType: TPasType; + ParamResolved: TPasResolverResult; +begin + Result:=cIncompatible; + if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then + exit; + Params:=TParamsExpr(Expr); + Param:=Params.Params[0]; + aType:=GetTypeInfoParamType(Param,ParamResolved,true); + if aType=nil then + RaiseMsg(20200826205441,nTypeIdentifierExpected,sTypeIdentifierExpected,[],Param); + + Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError); +end; + +procedure TPasResolver.BI_GetTypeKind_OnGetCallResult( + Proc: TResElDataBuiltInProc; Params: TParamsExpr; out + ResolvedEl: TPasResolverResult); +var + El: TPasElement; + EnumType: TPasEnumType; +begin + El:=FindSystemIdentifier('system','ttypekind',Params); + if not (El is TPasEnumType) then + RaiseXExpectedButYFound(20200826211458,'enum type System.TTypeKind',GetElementTypeName(El),Params); + EnumType:=TPasEnumType(El); + SetResolverTypeExpr(ResolvedEl,btContext,EnumType,EnumType,[rrfReadable]); + + if Proc=nil then ; +end; + +procedure TPasResolver.BI_GetTypeKind_OnEval(Proc: TResElDataBuiltInProc; + Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); +var + aType: TPasType; + El: TPasElement; + TypeKindType: TPasEnumType; + C: TClass; + aClass: TPasClassType; + bt: TResolverBaseType; + Value: TPasEnumValue; + aName: String; + i: Integer; + ParamResolved: TPasResolverResult; +begin + Evaluated:=nil; + + aType:=GetTypeInfoParamType(Params.Params[0],ParamResolved,true); + C:=aType.ClassType; + aName:='tkUnknown'; + if C=TPasEnumType then + aName:='tkEnumeration' + else if C=TPasSetType then + aName:='tkSet' + else if C=TPasRecordType then + aName:='tkRecord' + else if C=TPasClassType then + begin + aClass:=TPasClassType(aType); + case aClass.ObjKind of + okObject: aName:='tkObject'; + okInterface: + case aClass.InterfaceType of + citCom: aName:='tkInterface'; + else aName:='tkInterfaceRaw'; + end; + okClassHelper, okRecordHelper, okTypeHelper: aName:='tkHelper'; + else + aName:='tkClass'; + end; + end + else if C=TPasClassOfType then + aName:='tkClassRef' + else if C.InheritsFrom(TPasProcedure) then + aName:='tkMethod' + else if C.InheritsFrom(TPasProcedureType) then + aName:='tkProcVar' + else + begin + bt:=ParamResolved.BaseType; + case bt of + btChar: if BaseTypeChar=btAnsiChar then aName:='tkChar' else aName:='tkWChar'; + {$ifdef FPC_HAS_CPSTRING} + btAnsiChar: aName:='tkChar'; + {$endif} + btWideChar: aName:='tkWideChar'; + btString: if BaseTypeString=btAnsiString then aName:='tkAString' else aName:='tkUString'; + {$ifdef FPC_HAS_CPSTRING} + btAnsiString, + btShortString, + btRawByteString: aName:='tkAString'; + {$endif} + btWideString: aName:='tkWString'; + btUnicodeString: aName:='tkUString'; + btPointer: aName:='tkPointer'; + {$ifdef HasInt64} + btQWord, + btInt64, + btComp: aName:='tkInt64'; + {$endif} + else + if bt in btAllBooleans then + aName:='tkBool' + else if bt in btAllInteger then + aName:='tkInteger' + else if bt in btAllFloats then + aName:='tkFloat'; + end; + end; + + El:=FindSystemIdentifier('system','ttypekind',Params); + TypeKindType:=El as TPasEnumType; + + for i:=0 to TypeKindType.Values.Count-1 do + begin + Value:=TPasEnumValue(TypeKindType.Values[i]); + if SameText(aName,Value.Name) then + begin + Evaluated:=TResEvalEnum.CreateValue(i,Value); + exit; + end; + end; + + if Proc=nil then ; + if Flags=[] then ; +end; + function TPasResolver.BI_Assert_OnGetCallCompatibility( Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; // check params of built-in procedure 'Assert' @@ -21684,6 +21839,10 @@ begin AddBuiltInProc('TypeInfo','function TypeInfo(type or var identifier): Pointer', @BI_TypeInfo_OnGetCallCompatibility,@BI_TypeInfo_OnGetCallResult, nil,nil,bfTypeInfo); + if bfGetTypeKind in TheBaseProcs then + AddBuiltInProc('GetTypeKind','function GetTypeKind(type or var identifier): System.TTypeKind', + @BI_GetTypeKind_OnGetCallCompatibility,@BI_GetTypeKind_OnGetCallResult, + @BI_GetTypeKind_OnEval,nil,bfGetTypeKind); if bfAssert in TheBaseProcs then AddBuiltInProc('Assert','procedure Assert(bool[,string])', @BI_Assert_OnGetCallCompatibility,nil,nil, diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 942e81b128..1b0e3d3ed3 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -104,7 +104,8 @@ type TSystemUnitPart = ( supTObject, - supTVarRec + supTVarRec, + supTTypeKind ); TSystemUnitParts = set of TSystemUnitPart; @@ -322,6 +323,7 @@ type Procedure TestIncStringFail; Procedure TestTypeInfo; Procedure TestTypeInfo_FailRTTIDisabled; + Procedure TestGetTypeKind; // statements Procedure TestForLoop; @@ -2210,6 +2212,15 @@ begin Intf:=TStringList.Create; // interface Intf.Add('type'); + if supTTypeKind in Parts then + begin + Intf.Add(' TTypeKind=(tkUnknown,tkInteger,tkChar,tkEnumeration,tkFloat,'); + Intf.Add(' tkSet,tkMethod,tkSString,tkLString,tkAString,'); + Intf.Add(' tkWString,tkVariant,tkArray,tkRecord,tkInterface,'); + Intf.Add(' tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,'); + Intf.Add(' tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar,'); + Intf.Add(' tkHelper,tkFile,tkClassRef,tkPointer);'); + end; Intf.Add(' integer=longint;'); Intf.Add(' sizeint=int64;'); //'const', @@ -5065,6 +5076,44 @@ begin CheckResolverException(sSymbolCannotBePublished,nSymbolCannotBePublished); end; +procedure TTestResolver.TestGetTypeKind; +begin + StartProgram(true,[supTTypeKind]); + Add([ + 'type', + ' integer = longint;', + ' TRec = record', + ' v: integer;', + ' end;', + ' TClass = class of TObject;', + ' TObject = class', + ' class function ClassType: TClass; virtual; abstract;', + ' end;', + 'var', + ' i: integer;', + ' s: string;', + ' p: pointer;', + ' r: TRec;', + ' o: TObject;', + ' c: TClass;', + ' k: TTypeKind;', + 'begin', + ' k:=gettypekind(integer);', + ' k:=gettypekind(longint);', + ' k:=gettypekind(i);', + ' k:=gettypekind(s);', + ' k:=gettypekind(p);', + ' k:=gettypekind(r.v);', + ' k:=gettypekind(TObject.ClassType);', + ' k:=gettypekind(o.ClassType);', + ' k:=gettypekind(o);', + ' k:=gettypekind(c);', + ' k:=gettypekind(c.ClassType);', + ' k:=gettypekind(k);', + '']); + ParseProgram; +end; + procedure TTestResolver.TestForLoop; begin StartProgram(false);