From 224ba9844d80f5dde3cc3948971e00d110c80681 Mon Sep 17 00:00:00 2001 From: mattias Date: Wed, 23 Mar 2022 14:57:30 +0100 Subject: [PATCH] fcl-passrc: anonymous records (cherry picked from commit 35fd79ca523485df5e927e9f1a426dd9d814b530) --- packages/fcl-passrc/src/pasresolver.pp | 19 +- packages/fcl-passrc/src/pparser.pp | 12 +- packages/pastojs/src/fppas2js.pp | 8 +- packages/pastojs/tests/tcmodules.pas | 250 ++++++++++++++++++++++++- 4 files changed, 270 insertions(+), 19 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 9c8f8a36ed..1df14c5917 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -1612,6 +1612,7 @@ type procedure AddType(El: TPasType); virtual; procedure AddArrayType(El: TPasArrayType; TypeParams: TFPList); virtual; procedure AddRecordType(El: TPasRecordType; TypeParams: TFPList); virtual; + procedure AddRecordVariant(El: TPasVariant); virtual; procedure AddClassType(El: TPasClassType; TypeParams: TFPList); virtual; procedure AddVariable(El: TPasVariable); virtual; procedure AddResourceString(El: TPasResString); virtual; @@ -12065,6 +12066,9 @@ procedure TPasResolver.DeanonymizeType(El: TPasType); List.Add(El); end; 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; end; @@ -12259,16 +12263,19 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.AddRecordType ',GetObjName(El),' Parent=',GetObjName(El.Parent)); {$ENDIF} + C:=El.Parent.ClassType; if (El.Name='') then begin // anonymous record - C:=El.Parent.ClassType; if (C=TPasVariable) or (C=TPasConst) or (C=TPasVariant) then // ok else RaiseMsg(20220321224331,nCannotNestAnonymousX,sCannotNestAnonymousX,['record'],El); + if TypeParams<>nil then + RaiseNotYetImplemented(20220322220743,El); + DeanonymizeType(El); end; if TypeParams<>nil then @@ -12291,7 +12298,7 @@ begin FPendingForwardProcs.Add(El); // check forward declarations at the end end; - if El.Parent.ClassType<>TPasVariant then + if C<>TPasVariant then begin Scope:=TPasRecordScope(PushScope(El,ScopeClass_Record)); Scope.VisibilityContext:=El; @@ -12305,6 +12312,11 @@ begin end; end; +procedure TPasResolver.AddRecordVariant(El: TPasVariant); +begin + if El=nil then ; +end; + procedure TPasResolver.AddClassType(El: TPasClassType; TypeParams: TFPList); // Note: IsForward is not yet set! var @@ -21225,9 +21237,10 @@ begin end else if AClass=TPasRecordType then AddRecordType(TPasRecordType(El),TypeParams) + else if AClass=TPasVariant then + AddRecordVariant(TPasVariant(El)) else if AClass=TPasClassType then AddClassType(TPasClassType(El),TypeParams) - else if AClass=TPasVariant then else if AClass.InheritsFrom(TPasProcedure) then AddProcedure(TPasProcedure(El),TypeParams) else if AClass=TPasResultElement then diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 009a333e2e..a97b038186 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -7303,7 +7303,6 @@ var end; Function CheckSection : Boolean; - begin // Advanced records can have empty sections. { Use Case: @@ -7459,10 +7458,13 @@ begin begin CurEl:=TPasElement(ARec.Members[i]); if CurEl.ClassType=TPasAttributes then continue; - if isClass then - With TPasVariable(CurEl) do - VarModifiers:=VarModifiers + [vmClass]; - Engine.FinishScope(stDeclaration,TPasVariable(CurEl)); + if CurEl.ClassType=TPasVariable then + begin + if isClass then + With TPasVariable(CurEl) do + VarModifiers:=VarModifiers + [vmClass]; + Engine.FinishScope(stDeclaration,TPasVariable(CurEl)); + end; end; end; tkSquaredBraceOpen: diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index ca05193b20..36cb958cfa 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -1529,6 +1529,7 @@ type protected procedure AddType(El: TPasType); override; procedure AddRecordType(El: TPasRecordType; TypeParams: TFPList); override; + procedure AddRecordVariant(El: TPasVariant); override; procedure AddClassType(El: TPasClassType; TypeParams: TFPList); override; procedure AddEnumType(El: TPasEnumType); override; procedure ResolveImplAsm(El: TPasImplAsmStatement); override; @@ -3943,6 +3944,11 @@ begin AddElevatedLocal(El); end; +procedure TPas2JSResolver.AddRecordVariant(El: TPasVariant); +begin + RaiseMsg(20220323145350,nNotSupportedX,sNotSupportedX,['variant record'],El); +end; + procedure TPas2JSResolver.AddClassType(El: TPasClassType; TypeParams: TFPList); begin inherited AddClassType(El,TypeParams); @@ -27166,7 +27172,7 @@ begin aResolver:=AContext.Resolver; if not aResolver.IsFullySpecialized(El) then exit; {$IFDEF VerbosePas2JS} - writeln('TPasToJSConverter.ConvertRecordType ',GetObjName(El)); + writeln('TPasToJSConverter.ConvertRecordType ',GetObjPath(El)); {$ENDIF} FuncContext:=nil; NewFields:=nil; diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 348c0669d0..5338a01d09 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -528,7 +528,13 @@ type Procedure TestRecord_Const; Procedure TestRecord_TypecastFail; 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 Procedure TestAdvRecord_Function; @@ -12622,8 +12628,8 @@ begin ' 1: (i: word);', ' end;', 'begin']); - SetExpectedPasResolverError('variant record is not supported', - nXIsNotSupported); + SetExpectedPasResolverError('Not supported: variant record', + nNotSupportedX); ConvertProgram; end; @@ -12822,16 +12828,240 @@ begin ''])); end; -procedure TTestModule.TestRecord_AnonymousFail; +procedure TTestModule.TestRecordAnonym_Field; begin StartProgram(false); - Add([ - 'var', - ' r: record x: word end;', - 'begin']); - SetExpectedPasResolverError('not yet implemented: :TPasRecordType [20190408224556] "anonymous record type"', - nNotYetImplemented); + Add(['', + 'var Rec: record', + ' Bold: longint;', + ' end;', + 'begin', + ' rec.bold:=123;', + ' rec.bold:=rec.bold+7;', + '']); 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; procedure TTestModule.TestAdvRecord_Function;