fcl-passrc: resolver: GetTypeKind

git-svn-id: trunk@46704 -

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,

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);