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

pastojs: typecast to inline specialize

Browse Source 
git-svn-id: trunk@43207 -
This commit is contained in:
Mattias Gaertner 2019-10-16 10:15:40 +00:00
parent b70c6cc344
commit 0d4c008b46
2 changed files with 94 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9925,6 +9925,13 @@ begin
DotBin:=TBinaryExpr(Value);
Value:=DotBin.right;
end;
if (not (Value.CustomData is TResolvedReference))
and (aResolver<>nil)
and (Value is TInlineSpecializeExpr) then
begin
// Value<>()
Value:=TInlineSpecializeExpr(Value).NameExpr;
end;
if Value.CustomData is TResolvedReference then
begin

90
packages/pastojs/tests/tcgenerics.pas
View File

@ -22,8 +22,8 @@ type
Procedure TestGen_Class_EmptyMethod;
Procedure TestGen_Class_TList;
Procedure TestGen_ClassAncestor;
Procedure TestGen_TypeInfo;
// ToDo: TBird, TBird<T>, TBird<S,T>
Procedure TestGen_Class_TypeInfo;
Procedure TestGen_Class_TypeOverload; // ToDo TBird, TBird<T>, TBird<S,T>
// ToDo: rename local const T
// generic external class
@ -33,6 +33,7 @@ type
Procedure TestGen_InlineSpec_Constructor;
Procedure TestGen_CallUnitImplProc;
Procedure TestGen_IntAssignTemplVar;
Procedure TestGen_TypeCastDotField;
// ToDo: TBird<word>(o).field:=3;
// generic helper
@ -254,7 +255,7 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_TypeInfo;
procedure TTestGenerics.TestGen_Class_TypeInfo;
begin
Converter.Options:=Converter.Options-[coNoTypeInfo];
StartProgram(false);
@ -299,6 +300,39 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_Class_TypeOverload;
begin
exit;// ToDo
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class end;',
' TBird = word;',
' TBird<T> = class',
' m: T;',
' end;',
' TEagle = TBird<word>;',
'var',
' b: TBird<word>;',
' e: TEagle;',
'begin',
'']);
ConvertProgram;
CheckSource('TestGen_Class_TypeOverload',
LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
'});',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestGenerics.TestGen_ExtClass_Array;
begin
StartProgram(false);
@ -493,6 +527,56 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_TypeCastDotField;
begin
StartProgram(false);
Add([
'type',
' TObject = class end;',
' generic TBird<T> = class',
' Field: T;',
' procedure Fly;',
' end;',
'var',
' o: TObject;',
' b: specialize TBird<word>;',
'procedure TBird.Fly;',
'begin',
' specialize TBird<word>(o).Field:=3;',
' if 4=specialize TBird<word>(o).Field then ;',
'end;',
'begin',
' specialize TBird<word>(o).Field:=5;',
' if 6=specialize TBird<word>(o).Field then ;',
'']);
ConvertProgram;
CheckSource('TestGen_TypeCastDotField',
LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
'});',
'rtl.createClass($mod, "TBird$G1", $mod.TObject, function () {',
' this.$init = function () {',
' $mod.TObject.$init.call(this);',
' this.Field = 0;',
' };',
' this.Fly = function () {',
' $mod.o.Field = 3;',
' if (4 === $mod.o.Field) ;',
' };',
'});',
'this.o = null;',
'this.b = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.o.Field = 5;',
'if (6 === $mod.o.Field) ;',
'']));
end;
Initialization
RegisterTests([TTestGenerics]);
end.