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

fcl-passrc: anonymous records

Browse Source 
(cherry picked from commit 35fd79ca52)
This commit is contained in:
mattias 2022-03-23 14:57:30 +01:00 committed by Mattias Gaertner
parent 6aa3527f6a
commit 224ba9844d
4 changed files with 270 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
packages/fcl-passrc/src/pasresolver.pp
View File

@ -1612,6 +1612,7 @@ type
procedure AddType(El: TPasType); virtual; procedure AddType(El: TPasType); virtual;
procedure AddArrayType(El: TPasArrayType; TypeParams: TFPList); virtual; procedure AddArrayType(El: TPasArrayType; TypeParams: TFPList); virtual;
procedure AddRecordType(El: TPasRecordType; TypeParams: TFPList); virtual; procedure AddRecordType(El: TPasRecordType; TypeParams: TFPList); virtual;
procedure AddRecordVariant(El: TPasVariant); virtual;
procedure AddClassType(El: TPasClassType; TypeParams: TFPList); virtual; procedure AddClassType(El: TPasClassType; TypeParams: TFPList); virtual;
procedure AddVariable(El: TPasVariable); virtual; procedure AddVariable(El: TPasVariable); virtual;
procedure AddResourceString(El: TPasResString); virtual; procedure AddResourceString(El: TPasResString); virtual;
@ -12065,6 +12066,9 @@ procedure TPasResolver.DeanonymizeType(El: TPasType);
List.Add(El); List.Add(El);
end; end;
El.AddRef{$IFDEF CheckPasTreeRefCount}(aID){$ENDIF}; El.AddRef{$IFDEF CheckPasTreeRefCount}(aID){$ENDIF};
{$IFDEF VerbosePasResolver}
if El.Parent<>NewParent then writeln('TPasResolver.DeanonymizeType.InsertInFront OldParent=',GetObjName(El.Parent),' -> ',GetObjPath(NewParent));
{$ENDIF}
El.Parent:=NewParent; El.Parent:=NewParent;
end; end;
@ -12259,16 +12263,19 @@ begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.AddRecordType ',GetObjName(El),' Parent=',GetObjName(El.Parent)); writeln('TPasResolver.AddRecordType ',GetObjName(El),' Parent=',GetObjName(El.Parent));
{$ENDIF} {$ENDIF}
C:=El.Parent.ClassType;
if (El.Name='') then if (El.Name='') then
begin begin
// anonymous record // anonymous record
C:=El.Parent.ClassType;
if (C=TPasVariable) if (C=TPasVariable)
or (C=TPasConst) or (C=TPasConst)
or (C=TPasVariant) then or (C=TPasVariant) then
// ok // ok
else else
RaiseMsg(20220321224331,nCannotNestAnonymousX,sCannotNestAnonymousX,['record'],El); RaiseMsg(20220321224331,nCannotNestAnonymousX,sCannotNestAnonymousX,['record'],El);
if TypeParams<>nil then
RaiseNotYetImplemented(20220322220743,El);
DeanonymizeType(El);
end; end;
if TypeParams<>nil then if TypeParams<>nil then
@ -12291,7 +12298,7 @@ begin
FPendingForwardProcs.Add(El); // check forward declarations at the end FPendingForwardProcs.Add(El); // check forward declarations at the end
end; end;
if El.Parent.ClassType<>TPasVariant then if C<>TPasVariant then
begin begin
Scope:=TPasRecordScope(PushScope(El,ScopeClass_Record)); Scope:=TPasRecordScope(PushScope(El,ScopeClass_Record));
Scope.VisibilityContext:=El; Scope.VisibilityContext:=El;
@ -12305,6 +12312,11 @@ begin
end; end;
end; end;
procedure TPasResolver.AddRecordVariant(El: TPasVariant);
begin
if El=nil then ;
end;
procedure TPasResolver.AddClassType(El: TPasClassType; TypeParams: TFPList); procedure TPasResolver.AddClassType(El: TPasClassType; TypeParams: TFPList);
// Note: IsForward is not yet set! // Note: IsForward is not yet set!
var var
@ -21225,9 +21237,10 @@ begin
end end
else if AClass=TPasRecordType then else if AClass=TPasRecordType then
AddRecordType(TPasRecordType(El),TypeParams) AddRecordType(TPasRecordType(El),TypeParams)
else if AClass=TPasVariant then
AddRecordVariant(TPasVariant(El))
else if AClass=TPasClassType then else if AClass=TPasClassType then
AddClassType(TPasClassType(El),TypeParams) AddClassType(TPasClassType(El),TypeParams)
else if AClass=TPasVariant then
else if AClass.InheritsFrom(TPasProcedure) then else if AClass.InheritsFrom(TPasProcedure) then
AddProcedure(TPasProcedure(El),TypeParams) AddProcedure(TPasProcedure(El),TypeParams)
else if AClass=TPasResultElement then else if AClass=TPasResultElement then

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

@ -7303,7 +7303,6 @@ var
end; end;
Function CheckSection : Boolean; Function CheckSection : Boolean;
begin begin
// Advanced records can have empty sections. // Advanced records can have empty sections.
{ Use Case: { Use Case:
@ -7459,12 +7458,15 @@ begin
begin begin
CurEl:=TPasElement(ARec.Members[i]); CurEl:=TPasElement(ARec.Members[i]);
if CurEl.ClassType=TPasAttributes then continue; if CurEl.ClassType=TPasAttributes then continue;
if CurEl.ClassType=TPasVariable then
begin
if isClass then if isClass then
With TPasVariable(CurEl) do With TPasVariable(CurEl) do
VarModifiers:=VarModifiers + [vmClass]; VarModifiers:=VarModifiers + [vmClass];
Engine.FinishScope(stDeclaration,TPasVariable(CurEl)); Engine.FinishScope(stDeclaration,TPasVariable(CurEl));
end; end;
end; end;
end;
tkSquaredBraceOpen: tkSquaredBraceOpen:
if msPrefixedAttributes in CurrentModeswitches then if msPrefixedAttributes in CurrentModeswitches then
ParseAttributes(ARec,true) ParseAttributes(ARec,true)

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

@ -1529,6 +1529,7 @@ type
protected protected
procedure AddType(El: TPasType); override; procedure AddType(El: TPasType); override;
procedure AddRecordType(El: TPasRecordType; TypeParams: TFPList); override; procedure AddRecordType(El: TPasRecordType; TypeParams: TFPList); override;
procedure AddRecordVariant(El: TPasVariant); override;
procedure AddClassType(El: TPasClassType; TypeParams: TFPList); override; procedure AddClassType(El: TPasClassType; TypeParams: TFPList); override;
procedure AddEnumType(El: TPasEnumType); override; procedure AddEnumType(El: TPasEnumType); override;
procedure ResolveImplAsm(El: TPasImplAsmStatement); override; procedure ResolveImplAsm(El: TPasImplAsmStatement); override;
@ -3943,6 +3944,11 @@ begin
AddElevatedLocal(El); AddElevatedLocal(El);
end; end;
procedure TPas2JSResolver.AddRecordVariant(El: TPasVariant);
begin
RaiseMsg(20220323145350,nNotSupportedX,sNotSupportedX,['variant record'],El);
end;
procedure TPas2JSResolver.AddClassType(El: TPasClassType; TypeParams: TFPList); procedure TPas2JSResolver.AddClassType(El: TPasClassType; TypeParams: TFPList);
begin begin
inherited AddClassType(El,TypeParams); inherited AddClassType(El,TypeParams);
@ -27166,7 +27172,7 @@ begin
aResolver:=AContext.Resolver; aResolver:=AContext.Resolver;
if not aResolver.IsFullySpecialized(El) then exit; if not aResolver.IsFullySpecialized(El) then exit;
{$IFDEF VerbosePas2JS} {$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.ConvertRecordType ',GetObjName(El)); writeln('TPasToJSConverter.ConvertRecordType ',GetObjPath(El));
{$ENDIF} {$ENDIF}
FuncContext:=nil; FuncContext:=nil;
NewFields:=nil; NewFields:=nil;

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

@ -528,7 +528,13 @@ type
Procedure TestRecord_Const; Procedure TestRecord_Const;
Procedure TestRecord_TypecastFail; Procedure TestRecord_TypecastFail;
Procedure TestRecord_InFunction; Procedure TestRecord_InFunction;
Procedure TestRecord_AnonymousFail;
// anonymous record
Procedure TestRecordAnonym_Field;
Procedure TestRecordAnonym_Assign;
Procedure TestRecordAnonym_Nested;
Procedure TestRecordAnonym_Const;
Procedure TestRecordAnonym_InFunction;
// advanced record // advanced record
Procedure TestAdvRecord_Function; Procedure TestAdvRecord_Function;
@ -12622,8 +12628,8 @@ begin
' 1: (i: word);', ' 1: (i: word);',
' end;', ' end;',
'begin']); 'begin']);
SetExpectedPasResolverError('variant record is not supported', SetExpectedPasResolverError('Not supported: variant record',
nXIsNotSupported); nNotSupportedX);
ConvertProgram; ConvertProgram;
end; end;
@ -12822,16 +12828,240 @@ begin
''])); '']));
end; end;
procedure TTestModule.TestRecord_AnonymousFail; procedure TTestModule.TestRecordAnonym_Field;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add(['',
'var', 'var Rec: record',
' r: record x: word end;', ' Bold: longint;',
'begin']); ' end;',
SetExpectedPasResolverError('not yet implemented: :TPasRecordType [20190408224556] "anonymous record type"', 'begin',
nNotYetImplemented); ' rec.bold:=123;',
' rec.bold:=rec.bold+7;',
'']);
ConvertProgram; ConvertProgram;
CheckSource('TestRecordAnonym_Field',
LinesToStr([ // statements
'rtl.recNewT(this, "Rec$a", function () {',
' this.Bold = 0;',
' this.$eq = function (b) {',
' return this.Bold === b.Bold;',
' };',
' this.$assign = function (s) {',
' this.Bold = s.Bold;',
' return this;',
' };',
'});',
'this.Rec = this.Rec$a.$new();',
'']),
LinesToStr([ // $mod.$main
'$mod.Rec.Bold = 123;',
'$mod.Rec.Bold = $mod.Rec.Bold + 7;',
'']));
end;
procedure TTestModule.TestRecordAnonym_Assign;
begin
StartProgram(false);
Add(['',
'var S,T: record',
' Bold: longint;',
' end;',
' b: boolean;',
'begin',
' S:=T;',
' b:=s=t;',
'']);
ConvertProgram;
CheckSource('TestRecordAnonym_Assign',
LinesToStr([ // statements
'rtl.recNewT(this, "T$a", function () {',
' this.Bold = 0;',
' this.$eq = function (b) {',
' return this.Bold === b.Bold;',
' };',
' this.$assign = function (s) {',
' this.Bold = s.Bold;',
' return this;',
' };',
'});',
'this.S = this.T$a.$new();',
'this.T = this.T$a.$new();',
'this.b = false;',
'']),
LinesToStr([ // $mod.$main
'$mod.S.$assign($mod.T);',
'$mod.b = $mod.S.$eq($mod.T);',
'']));
end;
procedure TTestModule.TestRecordAnonym_Nested;
begin
StartProgram(false);
Add(['',
'var S,T: record',
' Bold: longint;',
' Sub: record',
' Color: word;',
' end;',
' end;',
' b: boolean;',
'begin',
' S:=T;',
' S.Sub:=T.Sub;',
' S.Sub.Color:=T.Sub.Color+3;',
' b:=s=t;',
' b:=s.Sub=t.Sub;',
'']);
ConvertProgram;
CheckSource('TestRecordAnonym_Nested',
LinesToStr([ // statements
'rtl.recNewT(this, "T$a", function () {',
' this.Bold = 0;',
' rtl.recNewT(this, "Sub$a", function () {',
' this.Color = 0;',
' this.$eq = function (b) {',
' return this.Color === b.Color;',
' };',
' this.$assign = function (s) {',
' this.Color = s.Color;',
' return this;',
' };',
' });',
' this.$new = function () {',
' var r = Object.create(this);',
' r.Sub = this.Sub$a.$new();',
' return r;',
' };',
' this.$eq = function (b) {',
' return (this.Bold === b.Bold) && this.Sub.$eq(b.Sub);',
' };',
' this.$assign = function (s) {',
' this.Bold = s.Bold;',
' this.Sub.$assign(s.Sub);',
' return this;',
' };',
'}, true);',
'this.S = this.T$a.$new();',
'this.T = this.T$a.$new();',
'this.b = false;',
'']),
LinesToStr([ // $mod.$main
'$mod.S.$assign($mod.T);',
'$mod.S.Sub.$assign($mod.T.Sub);',
'$mod.S.Sub.Color = $mod.T.Sub.Color + 3;',
'$mod.b = $mod.S.$eq($mod.T);',
'$mod.b = $mod.S.Sub.$eq($mod.T.Sub);',
'']));
end;
procedure TTestModule.TestRecordAnonym_Const;
begin
StartProgram(false);
Add(['',
'var T: record',
' Bold: longint;',
' Sub: record',
' Color: word;',
' end;',
' end = (Bold: 2; Sub: (Color: 3));',
'begin',
'']);
ConvertProgram;
CheckSource('TestRecordAnonym_Const',
LinesToStr([ // statements
'rtl.recNewT(this, "T$a", function () {',
' this.Bold = 0;',
' rtl.recNewT(this, "Sub$a", function () {',
' this.Color = 0;',
' this.$eq = function (b) {',
' return this.Color === b.Color;',
' };',
' this.$assign = function (s) {',
' this.Color = s.Color;',
' return this;',
' };',
' });',
' this.$new = function () {',
' var r = Object.create(this);',
' r.Sub = this.Sub$a.$new();',
' return r;',
' };',
' this.$eq = function (b) {',
' return (this.Bold === b.Bold) && this.Sub.$eq(b.Sub);',
' };',
' this.$assign = function (s) {',
' this.Bold = s.Bold;',
' this.Sub.$assign(s.Sub);',
' return this;',
' };',
'}, true);',
'this.T = this.T$a.$clone({',
' Bold: 2,',
' Sub: this.T$a.Sub$a.$clone({',
' Color: 3',
' })',
'});',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestModule.TestRecordAnonym_InFunction;
begin
StartProgram(false);
Add(['',
'procedure Fly;',
'var T: record',
' Bold: longint;',
' Sub: record',
' Color: word;',
' end;',
' end = (Bold: 2; Sub: (Color: 3));',
'begin',
'end;',
'begin',
'']);
ConvertProgram;
CheckSource('TestRecordAnonym_InFunction',
LinesToStr([ // statements
'var T$a = rtl.recNewT(null, "", function () {',
' this.Bold = 0;',
' rtl.recNewT(this, "Sub$a", function () {',
' this.Color = 0;',
' this.$eq = function (b) {',
' return this.Color === b.Color;',
' };',
' this.$assign = function (s) {',
' this.Color = s.Color;',
' return this;',
' };',
' });',
' this.$new = function () {',
' var r = Object.create(this);',
' r.Sub = this.Sub$a.$new();',
' return r;',
' };',
' this.$eq = function (b) {',
' return (this.Bold === b.Bold) && this.Sub.$eq(b.Sub);',
' };',
' this.$assign = function (s) {',
' this.Bold = s.Bold;',
' this.Sub.$assign(s.Sub);',
' return this;',
' };',
'}, true);',
'this.Fly = function () {',
' var T = T$a.$clone({',
' Bold: 2,',
' Sub: T$a.Sub$a.$clone({',
' Color: 3',
' })',
' });',
'};',
'']),
LinesToStr([ // $mod.$main
'']));
end; end;
procedure TTestModule.TestAdvRecord_Function; procedure TTestModule.TestAdvRecord_Function;