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

pastojs: shortrefglobals: local recordtype

Browse Source 
git-svn-id: trunk@46969 -
(cherry picked from commit 35f59b6736)
This commit is contained in:
Mattias Gaertner 2020-09-26 22:56:41 +00:00 committed by Florian Klämpfl
parent b15294a1e2
commit 9373cc981d
3 changed files with 119 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
packages/fcl-passrc/src/pparser.pp
View File

@ -123,11 +123,11 @@ resourcestring
SParserNoConstructorAllowed = 'Constructors or Destructors are not allowed in Interfaces or Records';
SParserNoFieldsAllowedInX = 'Fields are not allowed in %s';
SParserInvalidRecordVisibility = 'Records can only have public and (strict) private as visibility specifiers';
SErrRecordConstantsNotAllowed = 'Record constants not allowed at this location.';
SErrRecordVariablesNotAllowed = 'Record variables not allowed at this location.';
SErrRecordMethodsNotAllowed = 'Record methods not allowed at this location.';
SErrRecordPropertiesNotAllowed = 'Record properties not allowed at this location.';
SErrRecordTypesNotAllowed = 'Record types not allowed at this location.';
SErrRecordConstantsNotAllowed = 'Record constants not allowed at this location';
SErrRecordVariablesNotAllowed = 'Record variables not allowed at this location';
SErrRecordMethodsNotAllowed = 'Record methods not allowed at this location';
SErrRecordPropertiesNotAllowed = 'Record properties not allowed at this location';
SErrRecordTypesNotAllowed = 'Record types not allowed at this location';
SParserTypeNotAllowedHere = 'Type "%s" not allowed here';
SParserNotAnOperand = 'Not an operand: (%d : %s)';
SParserArrayPropertiesCannotHaveDefaultValue = 'Array properties cannot have default value';

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

@ -25422,7 +25422,8 @@ begin
RaiseNotSupported(El,AContext,20190105104054);
// local record type elevated to global scope
Src:=TJSSourceElements(AContext.JSElement);
VarSt:=CreateVarStatement(TransformElToJSName(El,AContext),Call,El);
JSName:=TransformElToJSName(El,AContext);
VarSt:=CreateVarStatement(JSName,Call,El);
AddToSourceElements(Src,VarSt); // keep Result=nil
// add parameter: parent = null
Call.AddArg(CreateLiteralNull(El));
@ -25459,7 +25460,7 @@ begin
FuncContext.ThisVar.Element:=El;
FuncContext.ThisVar.Kind:=cvkGlobal;
if coShortRefGlobals in Options then
if (coShortRefGlobals in Options) and not (El.Parent is TProcedureBody) then
begin
// $lt = this;
JSName:=AContext.GetLocalName(El,[cvkGlobal]);

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

@ -63,6 +63,7 @@ type
procedure TestOptShortRefGlobals_GenericFunction;
procedure TestOptShortRefGlobals_SameUnit_EnumType;
procedure TestOptShortRefGlobals_SameUnit_ClassType;
procedure TestOptShortRefGlobals_SameUnit_RecordType;
// Whole Program Optimization
procedure TestWPO_OmitLocalVar;
@ -619,7 +620,7 @@ begin
'end;',
'']);
ConvertUnit;
CheckSource('TestOptShortRefGlobals_SameUnit_EnumType',
CheckSource('TestOptShortRefGlobals_SameUnit_ClassType',
LinesToStr([
'var $impl = $mod.$impl;',
'var $lt = null;',
@ -667,6 +668,115 @@ begin
'']));
end;
procedure TTestOptimizations.TestOptShortRefGlobals_SameUnit_RecordType;
begin
StartUnit(true,[supTObject]);
Add([
'{$optimization JSShortRefGlobals}',
'{$modeswitch advancedrecords}',
'interface',
'type',
' TAnt = record',
' type',
' TLeg = record',
' l: word;',
' end;',
' procedure Run;',
' Leg: TLeg;',
' end;',
'implementation',
'type',
' TBird = record',
' b: word;',
' end;',
'procedure TAnt.Run;',
'type',
' TFoot = record',
' f: word;',
' end;',
'var',
' b: TBird;',
' l: TLeg;',
' a: TAnt;',
' f: TFoot;',
'begin',
' b.b:=1;',
' l.l:=2;',
' a.Leg.l:=3;',
' f.f:=4;',
'end;',
'']);
ConvertUnit;
CheckSource('TestOptShortRefGlobals_SameUnit_RecordType',
LinesToStr([
'var $impl = $mod.$impl;',
'var $lt = null;',
'var $lt1 = null;',
'var $lt2 = null;',
'rtl.recNewT(this, "TAnt", function () {',
' $lt = this;',
' rtl.recNewT($lt, "TLeg", function () {',
' $lt1 = this;',
' this.l = 0;',
' this.$eq = function (b) {',
' return this.l === b.l;',
' };',
' this.$assign = function (s) {',
' this.l = s.l;',
' return this;',
' };',
' });',
' this.$new = function () {',
' var r = Object.create(this);',
' r.Leg = $lt1.$new();',
' return r;',
' };',
' this.$eq = function (b) {',
' return this.Leg.$eq(b.Leg);',
' };',
' this.$assign = function (s) {',
' this.Leg.$assign(s.Leg);',
' return this;',
' };',
' var TFoot = rtl.recNewT(null, "", function () {',
' this.f = 0;',
' this.$eq = function (b) {',
' return this.f === b.f;',
' };',
' this.$assign = function (s) {',
' this.f = s.f;',
' return this;',
' };',
' });',
' this.Run = function () {',
' var b = $lt2.$new();',
' var l = $lt1.$new();',
' var a = $lt.$new();',
' var f = TFoot.$new();',
' b.b = 1;',
' l.l = 2;',
' a.Leg.l = 3;',
' f.f = 4;',
' };',
'}, true);',
'']),
LinesToStr([
'']),
LinesToStr([
'rtl.recNewT($impl, "TBird", function () {',
' $lt2 = this;',
' this.b = 0;',
' this.$eq = function (b) {',
' return this.b === b.b;',
' };',
' this.$assign = function (s) {',
' this.b = s.b;',
' return this;',
' };',
'});',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitLocalVar;
begin
StartProgram(false);