mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-01 00:30:56 +02:00
fcl-passrc: resolver: GetTypeKind
git-svn-id: trunk@46704 -
This commit is contained in:
Mattias Gaertner
parent
f30f62231f
commit
13903e44f4
@ -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,
|
||||
|
||||
@ -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);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user