pastojs: GetTypeKind

git-svn-id: trunk@46705 -

packages/pastojs/src/fppas2js.pp

@@ -2122,6 +2122,7 @@ type
     Function ConvertBuiltIn_InsertArray(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_DeleteArray(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_TypeInfo(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
+    Function ConvertBuiltIn_GetTypeKind(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_Assert(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_New(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_Dispose(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
@@ -4976,6 +4977,8 @@ begin
   GenMod:=nil;
   GenResolver:=nil;
 
+  // ToDo: delay only, if either RTTI or class var using a param
+
   Params:=SpecializedItem.Params;
   for i:=0 to length(Params)-1 do
     begin
@@ -10949,6 +10952,7 @@ begin
           bfInsertArray: Result:=ConvertBuiltIn_InsertArray(El,AContext);
           bfDeleteArray: Result:=ConvertBuiltIn_DeleteArray(El,AContext);
           bfTypeInfo: Result:=ConvertBuiltIn_TypeInfo(El,AContext);
+          bfGetTypeKind: Result:=ConvertBuiltIn_GetTypeKind(El,AContext);
           bfAssert:
             begin
             Result:=ConvertBuiltIn_Assert(El,AContext);
@@ -13529,6 +13533,24 @@ begin
     Result:=CreateTypeInfoRef(TypeEl,AContext,Param);
 end;
 
+function TPasToJSConverter.ConvertBuiltIn_GetTypeKind(El: TParamsExpr;
+  AContext: TConvertContext): TJSElement;
+var
+  aResolver: TPas2JSResolver;
+  Value: TResEvalValue;
+begin
+  Result:=nil;
+  aResolver:=AContext.Resolver;
+  aResolver.BI_GetTypeKind_OnEval(aResolver.BuiltInProcs[bfGetTypeKind],El,[refConst],Value);
+  try
+    if not (Value is TResEvalEnum) then
+      RaiseNotSupported(El,AContext,20200826222729,GetObjName(Value));
+    Result:=CreateLiteralNumber(El,TResEvalEnum(Value).Index);
+  finally
+    ReleaseEvalValue(Value);
+  end;
+end;
+
 function TPasToJSConverter.ConvertBuiltIn_Assert(El: TParamsExpr;
   AContext: TConvertContext): TJSElement;
 // throw pas.SysUtils.EAssertionFailed.$create("Create");

packages/pastojs/tests/tcmodules.pas

@@ -1670,6 +1670,39 @@ begin
     begin
     Intf.AddStrings([
     'type',
+    '  TTypeKind = (',
+    '    tkUnknown,  // 0',
+    '    tkInteger,  // 1',
+    '    tkChar,     // 2 in Delphi/FPC tkWChar, tkUChar',
+    '    tkString,   // 3 in Delphi/FPC tkSString, tkWString or tkUString',
+    '    tkEnumeration, // 4',
+    '    tkSet,      // 5',
+    '    tkDouble,   // 6',
+    '    tkBool,     // 7',
+    '    tkProcVar,  // 8  function or procedure',
+    '    tkMethod,   // 9  proc var of object',
+    '    tkArray,    // 10 static array',
+    '    tkDynArray, // 11',
+    '    tkRecord,   // 12',
+    '    tkClass,    // 13',
+    '    tkClassRef, // 14',
+    '    tkPointer,  // 15',
+    '    tkJSValue,  // 16',
+    '    tkRefToProcVar, // 17  variable of procedure type',
+    '    tkInterface, // 18',
+    '    //tkObject,',
+    '    //tkSString,tkLString,tkAString,tkWString,',
+    '    //tkVariant,',
+    '    //tkWChar,',
+    '    //tkInt64,',
+    '    //tkQWord,',
+    '    //tkInterfaceRaw,',
+    '    //tkUString,tkUChar,',
+    '    tkHelper,   // 19',
+    '    //tkFile,',
+    '    tkExtClass  // 20',
+    '    );',
+    '  TTypeKinds = set of TTypeKind;',
     '  TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
     '  TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo)',
     '  end;',
@@ -28478,9 +28511,12 @@ begin
   '  TColor = type TGraphicsColor;',
   'var',
   '  p: TTypeInfo;',
+  '  k: TTypeKind;',
   'begin',
   '  p:=typeinfo(TGraphicsColor);',
   '  p:=typeinfo(TColor);',
+  '  k:=GetTypeKind(TGraphicsColor);',
+  '  k:=GetTypeKind(TColor);',
   '']);
   ConvertProgram;
   CheckSource('TestRTTI_IntRange',
@@ -28492,10 +28528,13 @@ begin
     '});',
     '$mod.$rtti.$inherited("TColor", $mod.$rtti["TGraphicsColor"], {});',
     'this.p = null;',
+    'this.k = 0;',
     '']),
     LinesToStr([ // $mod.$main
     '$mod.p = $mod.$rtti["TGraphicsColor"];',
     '$mod.p = $mod.$rtti["TColor"];',
+    '$mod.k = 1;',
+    '$mod.k = 1;',
     '']));
 end;