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

pastojs: classname=typeinfoname

Browse Source 
git-svn-id: trunk@46986 -
This commit is contained in:
Mattias Gaertner 2020-09-28 09:39:24 +00:00
parent 7c238c24e8
commit a66b6cd7c7
8 changed files with 152 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15177,7 +15177,8 @@ begin
end;// end of init function
// for specialization: add RTTI name
if (Scope.JSName<>'') and (Scope.JSName<>El.Name) and HasTypeInfo(El,AContext) then
if ((Scope.JSName<>'') and (Scope.JSName<>El.Name))
or (El.Parent is TPasMembersType) then
begin
Call.AddArg(CreateLiteralString(El,GetTypeInfoName(El,AContext,El)));
end;

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

@ -27,7 +27,7 @@ type
Procedure TestGen_ClassEmpty;
Procedure TestGen_Class_EmptyMethod;
Procedure TestGen_Class_TList;
Procedure TestGen_Class_TCustomList;
Procedure TestGen_Class_TCustomList; // ToDo: with Self do Result:=Method()
Procedure TestGen_ClassAncestor;
Procedure TestGen_Class_TypeInfo;
Procedure TestGen_Class_TypeOverload; // ToDo TBird, TBird<T>, TBird<S,T>
@ -37,12 +37,13 @@ type
Procedure TestGen_Class_ClassConstructor;
Procedure TestGen_Class_TypeCastSpecializesWarn;
Procedure TestGen_Class_TypeCastSpecializesJSValueNoWarn;
procedure TestGen_Class_VarArgsOfType;
procedure TestGen_Class_OverloadsInUnit;
procedure TestGen_ClassForward_CircleRTTI;
procedure TestGen_Class_Nested_RTTI;
Procedure TestGen_Class_ClassVarRecord_UnitImpl;
// generic external class
procedure TestGen_ExtClass_VarArgsOfType;
procedure TestGen_ExtClass_Array;
procedure TestGen_ExtClass_GenJSValueAssign;
procedure TestGen_ExtClass_AliasMemberType;
@ -365,7 +366,7 @@ begin
' };',
'});',
'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
'});',
'}, "TBird<System.Word>");',
'this.a = null;',
'this.b = null;',
'']),
@ -403,7 +404,7 @@ begin
' var Result = 0;',
' return Result;',
' };',
'});',
'}, "TBird<System.Word>");',
'this.a = null;',
'']),
LinesToStr([ // $mod.$main
@ -479,7 +480,7 @@ begin
' this.FItems.splice(2, 0, w);',
' this.FItems.splice(2, 3);',
' };',
'});',
'}, "TList<System.Word>");',
'this.l = null;',
'this.w = 0;',
'']),
@ -511,7 +512,7 @@ begin
'function TList<T>.Add: word;',
'begin',
' Result:=PrepareAddingItem;',
//' Result:=Self.PrepareAddingItem;',
' Result:=Self.PrepareAddingItem;',
//' with Self do Result:=PrepareAddingItem;',
'end;',
'var l: TWordList;',
@ -531,14 +532,15 @@ begin
' var Result = 0;',
' return Result;',
' };',
'});',
'}, "TCustomList<System.Word>");',
'rtl.createClass(this, "TList$G1", this.TCustomList$G2, function () {',
' this.Add = function () {',
' var Result = 0;',
' Result = this.PrepareAddingItem();',
' Result = this.PrepareAddingItem();',
' return Result;',
' };',
'});',
'}, "TList<System.Word>");',
'this.l = null;',
'']),
LinesToStr([ // $mod.$main
@ -568,9 +570,9 @@ begin
' };',
'});',
'rtl.createClass(this, "TBird$G2", this.TObject, function () {',
'});',
'}, "TBird<System.Word>");',
'rtl.createClass(this, "TEagle$G1", this.TBird$G2, function () {',
'});',
'}, "TEagle<System.Word>");',
'this.a = null;',
'']),
LinesToStr([ // $mod.$main
@ -684,7 +686,7 @@ begin
'});',
'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
' this.fSize = 0;',
'});',
'}, "TBird<System.Word>");',
'']),
LinesToStr([ // $mod.$main
'$mod.TBird$G1.fSize = 3 + $mod.TBird$G1.fSize;',
@ -750,7 +752,7 @@ begin
' this.Run();',
' $mod.TPoint$G1.Run();',
' };',
'});',
'}, "TPoint<System.Word>");',
'this.p = null;',
'']),
LinesToStr([ // $mod.$main
@ -800,13 +802,13 @@ begin
' this.x = 0;',
' this.Fly = function () {',
' };',
'});',
'}, "TPoint<System.Word>");',
'this.r = null;',
'rtl.createClass(this, "TPoint$G2", this.TObject, function () {',
' this.x = 0;',
' this.Fly = function () {',
' };',
'});',
'}, "TPoint<System.SmallInt>");',
'this.s = null;',
'']),
LinesToStr([ // $mod.$main
@ -858,13 +860,13 @@ begin
' $mod.TObject.$init.call(this);',
' this.F = 0;',
' };',
'});',
'}, "TBird<System.Word>");',
'rtl.createClass(this, "TBird$G2", this.TObject, function () {',
' this.$init = function () {',
' $mod.TObject.$init.call(this);',
' this.F = "";',
' };',
'});',
'}, "TBird<System.Char>");',
'this.w = null;',
'this.c = null;',
'']),
@ -906,13 +908,13 @@ begin
' $mod.TObject.$init.call(this);',
' this.F = 0;',
' };',
'});',
'}, "TBird<System.Word>");',
'rtl.createClass(this, "TBird$G2", this.TObject, function () {',
' this.$init = function () {',
' $mod.TObject.$init.call(this);',
' this.F = undefined;',
' };',
'});',
'}, "TBird<System.JSValue>");',
'this.w = null;',
'this.a = null;',
'']),
@ -923,45 +925,6 @@ begin
CheckResolverUnexpectedHints();
end;
procedure TTestGenerics.TestGen_Class_VarArgsOfType;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'{$modeswitch externalclass}',
'type',
' TJSObject = class external name ''Object''',
' end;',
' generic TGJSSet<T> = class external name ''Set''',
' constructor new(aElement1: T); varargs of T; overload;',
' function bind(thisArg: TJSObject): T; varargs of T;',
' end;',
' TJSWordSet = specialize TGJSSet<word>;',
'var',
' s: TJSWordSet;',
' w: word;',
'begin',
' s:=TJSWordSet.new(3);',
' s:=TJSWordSet.new(3,5);',
' w:=s.bind(nil);',
' w:=s.bind(nil,6);',
' w:=s.bind(nil,7,8);',
'']);
ConvertProgram;
CheckSource('TestGen_Class_VarArgsOfType',
LinesToStr([ // statements
'this.s = null;',
'this.w = 0;',
'']),
LinesToStr([ // $mod.$main
'$mod.s = new Set(3);',
'$mod.s = new Set(3, 5);',
'$mod.w = $mod.s.bind(null);',
'$mod.w = $mod.s.bind(null, 6);',
'$mod.w = $mod.s.bind(null, 7, 8);',
'']));
end;
procedure TTestGenerics.TestGen_Class_OverloadsInUnit;
begin
StartProgram(true,[supTObject]);
@ -1013,7 +976,7 @@ begin
' this.Create$2 = function (b) {',
' return this;',
' };',
' });',
' }, "TBird<System.Word>");',
' rtl.createClass(this, "TBird$G2", pas.system.TObject, function () {',
' this.c = 13;',
' var c$1 = 14;',
@ -1024,7 +987,7 @@ begin
' this.Create$2 = function (b) {',
' return this;',
' };',
' });',
' }, "TBird<System.Double>");',
'});',
'']));
CheckSource('TestGen_Class_OverloadsInUnit',
@ -1115,6 +1078,57 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_Class_Nested_RTTI;
begin
WithTypeInfo:=true;
StartProgram(true,[supTObject]);
AddModuleWithIntfImplSrc('UnitA.pas',
LinesToStr([
'type',
' generic TAnt<T> = class',
' type',
' TLeg = class',
' published',
' Size: T;',
' end;',
' end;',
' TBoolAnt = specialize TAnt<boolean>;',
'']),
LinesToStr([
'']));
Add([
'uses UnitA;',
'var',
' BoolLeg: TBoolAnt.TLeg;',
'begin',
' if typeinfo(TBoolAnt.TLeg)=nil then ;',
'']);
ConvertProgram;
CheckUnit('UnitA.pas',
LinesToStr([ // statements
'rtl.module("UnitA", ["system"], function () {',
' var $mod = this;',
' $mod.$rtti.$Class("TAnt<System.Boolean>");',
' rtl.createClass(this, "TAnt$G1", pas.system.TObject, function () {',
' rtl.createClass(this, "TLeg", pas.system.TObject, function () {',
' this.$init = function () {',
' pas.system.TObject.$init.call(this);',
' this.Size = false;',
' };',
' var $r = this.$rtti;',
' $r.addField("Size", rtl.boolean);',
' }, "TAnt<System.Boolean>.TLeg");',
' }, "TAnt<System.Boolean>");',
'});']));
CheckSource('TestGen_Class_Nested_RTTI',
LinesToStr([ // statements
'this.BoolLeg = null;',
'']),
LinesToStr([ // $mod.$main
'if (pas.UnitA.$rtti["TAnt<System.Boolean>.TLeg"] === null) ;',
'']));
end;
procedure TTestGenerics.TestGen_Class_ClassVarRecord_UnitImpl;
begin
StartProgram(true,[supTObject]);
@ -1151,7 +1165,7 @@ begin
' this.x = $impl.TBird.$new();',
' this.a = rtl.arraySetLength(null, $impl.TBird, 2);',
' };',
' });',
' }, "TAnt<UnitA.TBird>");',
' $mod.$implcode = function () {',
' rtl.recNewT($impl, "TBird", function () {',
' this.b = 0;',
@ -1168,7 +1182,8 @@ begin
' $mod.$init = function () {',
' $impl.f.x.b = $impl.f.x.b + 10;',
' };',
'}, []);']));
'}, []);',
'']));
CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
LinesToStr([ // statements
'pas.UnitA.TAnt$G1.$initSpec();',
@ -1177,6 +1192,45 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_ExtClass_VarArgsOfType;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'{$modeswitch externalclass}',
'type',
' TJSObject = class external name ''Object''',
' end;',
' generic TGJSSet<T> = class external name ''Set''',
' constructor new(aElement1: T); varargs of T; overload;',
' function bind(thisArg: TJSObject): T; varargs of T;',
' end;',
' TJSWordSet = specialize TGJSSet<word>;',
'var',
' s: TJSWordSet;',
' w: word;',
'begin',
' s:=TJSWordSet.new(3);',
' s:=TJSWordSet.new(3,5);',
' w:=s.bind(nil);',
' w:=s.bind(nil,6);',
' w:=s.bind(nil,7,8);',
'']);
ConvertProgram;
CheckSource('TestGen_ExtClass_VarArgsOfType',
LinesToStr([ // statements
'this.s = null;',
'this.w = 0;',
'']),
LinesToStr([ // $mod.$main
'$mod.s = new Set(3);',
'$mod.s = new Set(3, 5);',
'$mod.w = $mod.s.bind(null);',
'$mod.w = $mod.s.bind(null, 6);',
'$mod.w = $mod.s.bind(null, 7, 8);',
'']));
end;
procedure TTestGenerics.TestGen_ExtClass_Array;
begin
StartProgram(false);
@ -1431,10 +1485,17 @@ begin
' this.$final = function () {',
' };',
'});',
'rtl.createInterface(this, "IBird$G2", "{33AB51C6-6240-3BDF-B4B0-D48A593EAB0A}", ["GetSize", "SetSize", "DoIt"], this.IUnknown);',
'rtl.createInterface(',
' this,',
' "IBird$G2",',
' "{33AB51C6-6240-3BDF-B4B0-D48A593EAB0A}",',
' ["GetSize", "SetSize", "DoIt"],',
' this.IUnknown,',
' "IBird<System.Word>"',
');',
'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
' rtl.addIntf(this, $mod.IBird$G2);',
'});',
'}, "TBird<System.Word>");',
'this.BirdIntf = null;',
'']),
LinesToStr([ // $mod.$main
@ -1463,7 +1524,14 @@ begin
ConvertProgram;
CheckSource('TestGen_ClassInterface_InterfacedObject',
LinesToStr([ // statements
'rtl.createInterface(this, "IComparer$G2", "{505778ED-F783-4456-9691-32F419CC5E18}", ["Compare"], pas.system.IUnknown);',
'rtl.createInterface(',
' this,',
' "IComparer$G2",',
' "{505778ED-F783-4456-9691-32F419CC5E18}",',
' ["Compare"],',
' pas.system.IUnknown,',
' "IComparer<System.Longint>"',
');',
'this.aComparer = null;',
'rtl.createClass(this, "TComparer$G1", pas.system.TInterfacedObject, function () {',
' this.Compare = function (Left, Right) {',
@ -1472,7 +1540,7 @@ begin
' };',
' rtl.addIntf(this, $mod.IComparer$G2);',
' rtl.addIntf(this, pas.system.IUnknown);',
'});',
'}, "TComparer<System.Longint>");',
'']),
LinesToStr([ // $mod.$main
'rtl.setIntfP($mod, "aComparer", rtl.queryIntfT($mod.TComparer$G1.$create("Create"), $mod.IComparer$G2), true);',
@ -1549,7 +1617,7 @@ begin
' };',
'});',
'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
'});',
'}, "TBird<System.Word>");',
'this.b = null;',
'']),
LinesToStr([ // $mod.$main
@ -1592,13 +1660,13 @@ begin
' this.Fly = function () {',
' $impl.DoIt();',
' };',
' });',
' }, "TBird<System.Boolean>");',
' this.b = null;',
' rtl.createClass(this, "TBird$G2", pas.system.TObject, function () {',
' this.Fly = function () {',
' $impl.DoIt();',
' };',
' });',
' }, "TBird<System.Word>");',
' $mod.$implcode = function () {',
' $impl.DoIt = function () {',
' var b = null;',
@ -1646,7 +1714,7 @@ begin
' var i = 0;',
' i = this.m;',
' };',
'});',
'}, "TBird<System.Word>");',
'this.b = null;',
'']),
LinesToStr([ // $mod.$main
@ -1694,7 +1762,7 @@ begin
' $mod.o.Field = 3;',
' if (4 === $mod.o.Field) ;',
' };',
'});',
'}, "TBird<System.Word>");',
'this.b = null;',
'']),
LinesToStr([ // $mod.$main

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

@ -11964,7 +11964,7 @@ begin
' this.Glob();',
' this.Glob();',
' };',
' });',
' }, "TPoint.TBird");',
' this.$eq = function (b) {',
' return true;',
' };',
@ -16395,7 +16395,7 @@ begin
' this.FId = i;',
' return Result;',
' };',
' });',
' }, "TBird.TLeg");',
' this.DoIt = function (b) {',
' var Result = null;',
' Result.Create();',

2
packages/pastojs/tests/tcoptimizations.pas
View File

@ -634,7 +634,7 @@ begin
' $lt = this;',
' rtl.createClass(this, "TLeg", $lt4, function () {',
' $lt1 = this;',
' });',
' }, "TAnt.TLeg");',
' this.$init = function () {',
' $lt4.$init.call(this);',
' this.Bird = null;',

2
packages/pastojs/tests/tcsrcmap.pas
View File

@ -16,7 +16,7 @@
Examples:
./testpas2js --suite=TTestSrcMap.TestEmptyProgram
}
unit tcsrcmap;
unit TCSrcMap;
{$mode objfpc}{$H+}

1
packages/pastojs/tests/testpas2js.lpi
View File

@ -64,6 +64,7 @@
<Unit5>
<Filename Value="tcsrcmap.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TCSrcMap"/>
</Unit5>
<Unit6>
<Filename Value="../src/fppjssrcmap.pp"/>

4
packages/pastojs/tests/testpas2js.pp
View File

@ -20,8 +20,8 @@ uses
{$IFDEF EnableMemCheck}
MemCheck,
{$ENDIF}
Classes, consoletestrunner, tcconverter, TCModules, tcoptimizations, tcsrcmap,
tcfiler, tcunitsearch, tcprecompile, TCGenerics;
Classes, consoletestrunner, tcconverter, TCModules, TCSrcMap,
TCFiler, TCUnitSearch, TCOptimizations, TCGenerics, TCPrecompile;
type

11
utils/pas2js/dist/rtl.js vendored
View File

@ -286,15 +286,14 @@ var rtl = {
},
initClass: function(c,parent,name,initfn,rttiname){
if (!rttiname) rttiname = name;
parent[name] = c;
c.$class = c; // Note: o.$class === Object.getPrototypeOf(o)
c.$classname = rttiname;
c.$classname = rttiname?rttiname:name;
parent = rtl.initStruct(c,parent,name);
c.$fullname = parent.$name+'.'+name;
// rtti
if (rtl.debug_rtti) rtl.debug('initClass '+c.$fullname);
var t = c.$module.$rtti.$Class(rttiname,{ "class": c });
var t = c.$module.$rtti.$Class(c.$classname,{ "class": c });
c.$rtti = t;
if (rtl.isObject(c.$ancestor)) t.ancestor = c.$ancestor.$rtti;
if (!t.ancestor) t.ancestor = null;
@ -402,7 +401,7 @@ var rtl = {
}
},
createHelper: function(parent,name,ancestor,initfn){
createHelper: function(parent,name,ancestor,initfn,rttiname){
// create a helper,
// ancestor must be null or a helper,
var c = null;
@ -415,11 +414,11 @@ var rtl = {
};
parent[name] = c;
c.$class = c; // Note: o.$class === Object.getPrototypeOf(o)
c.$classname = name;
c.$classname = rttiname?rttiname:name;
parent = rtl.initStruct(c,parent,name);
c.$fullname = parent.$name+'.'+name;
// rtti
var t = c.$module.$rtti.$Helper(c.$name,{ "helper": c });
var t = c.$module.$rtti.$Helper(c.$classname,{ "helper": c });
c.$rtti = t;
if (rtl.isObject(ancestor)) t.ancestor = ancestor.$rtti;
if (!t.ancestor) t.ancestor = null;