fcl-passrc: anonymous records

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

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:

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;

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;