paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 20:11:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

pastojs: GetTypeKind

Browse Source 
git-svn-id: trunk@46705 -
This commit is contained in:
Mattias Gaertner 2020-08-26 20:30:56 +00:00
parent 13903e44f4
commit 7a87452764
2 changed files with 61 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
packages/pastojs/src/fppas2js.pp
View File

@ -2122,6 +2122,7 @@ type
Function ConvertBuiltIn_InsertArray(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual; Function ConvertBuiltIn_InsertArray(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBuiltIn_DeleteArray(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_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_Assert(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBuiltIn_New(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual; Function ConvertBuiltIn_New(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBuiltIn_Dispose(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual; Function ConvertBuiltIn_Dispose(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
@ -4976,6 +4977,8 @@ begin
GenMod:=nil; GenMod:=nil;
GenResolver:=nil; GenResolver:=nil;
// ToDo: delay only, if either RTTI or class var using a param
Params:=SpecializedItem.Params; Params:=SpecializedItem.Params;
for i:=0 to length(Params)-1 do for i:=0 to length(Params)-1 do
begin begin
@ -10949,6 +10952,7 @@ begin
bfInsertArray: Result:=ConvertBuiltIn_InsertArray(El,AContext); bfInsertArray: Result:=ConvertBuiltIn_InsertArray(El,AContext);
bfDeleteArray: Result:=ConvertBuiltIn_DeleteArray(El,AContext); bfDeleteArray: Result:=ConvertBuiltIn_DeleteArray(El,AContext);
bfTypeInfo: Result:=ConvertBuiltIn_TypeInfo(El,AContext); bfTypeInfo: Result:=ConvertBuiltIn_TypeInfo(El,AContext);
bfGetTypeKind: Result:=ConvertBuiltIn_GetTypeKind(El,AContext);
bfAssert: bfAssert:
begin begin
Result:=ConvertBuiltIn_Assert(El,AContext); Result:=ConvertBuiltIn_Assert(El,AContext);
@ -13529,6 +13533,24 @@ begin
Result:=CreateTypeInfoRef(TypeEl,AContext,Param); Result:=CreateTypeInfoRef(TypeEl,AContext,Param);
end; 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; function TPasToJSConverter.ConvertBuiltIn_Assert(El: TParamsExpr;
AContext: TConvertContext): TJSElement; AContext: TConvertContext): TJSElement;
// throw pas.SysUtils.EAssertionFailed.$create("Create"); // throw pas.SysUtils.EAssertionFailed.$create("Create");

39
packages/pastojs/tests/tcmodules.pas
View File

@ -1670,6 +1670,39 @@ begin
begin begin
Intf.AddStrings([ Intf.AddStrings([
'type', '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;', ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo)', ' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo)',
' end;', ' end;',
@ -28478,9 +28511,12 @@ begin
' TColor = type TGraphicsColor;', ' TColor = type TGraphicsColor;',
'var', 'var',
' p: TTypeInfo;', ' p: TTypeInfo;',
' k: TTypeKind;',
'begin', 'begin',
' p:=typeinfo(TGraphicsColor);', ' p:=typeinfo(TGraphicsColor);',
' p:=typeinfo(TColor);', ' p:=typeinfo(TColor);',
' k:=GetTypeKind(TGraphicsColor);',
' k:=GetTypeKind(TColor);',
'']); '']);
ConvertProgram; ConvertProgram;
CheckSource('TestRTTI_IntRange', CheckSource('TestRTTI_IntRange',
@ -28492,10 +28528,13 @@ begin
'});', '});',
'$mod.$rtti.$inherited("TColor", $mod.$rtti["TGraphicsColor"], {});', '$mod.$rtti.$inherited("TColor", $mod.$rtti["TGraphicsColor"], {});',
'this.p = null;', 'this.p = null;',
'this.k = 0;',
'']), '']),
LinesToStr([ // $mod.$main LinesToStr([ // $mod.$main
'$mod.p = $mod.$rtti["TGraphicsColor"];', '$mod.p = $mod.$rtti["TGraphicsColor"];',
'$mod.p = $mod.$rtti["TColor"];', '$mod.p = $mod.$rtti["TColor"];',
'$mod.k = 1;',
'$mod.k = 1;',
''])); '']));
end; end;