pastojs: record const

git-svn-id: trunk@38869 -

packages/pastojs/src/fppas2js.pp

@@ -81,6 +81,8 @@ Works:
   - clone set member
   - clone when passing as argument
   - equal, not equal
+  - const
+  - array of record-const
 - classes
   - declare using createClass
   - constructor
@@ -373,7 +375,6 @@ Not in Version 1.0:
 - sets
   - set of char, boolean, integer range, char range, enum range
 - call array of proc element without ()
-- record const
 - enums with custom values
 - library
 - constref
@@ -1193,7 +1194,7 @@ type
       RHS: TPasExpr); override;
     function HasStaticArrayCloneFunc(Arr: TPasArrayType): boolean;
     function IsTGUID(TypeEl: TPasRecordType): boolean; override;
-    function GetAssignGUIDString(TypeEl: TPasRecordType; Expr: TPasExpr; out GUID: TGUID): boolean;
+    function GetAssignGUIDString(TypeEl: TPasRecordType; Expr: TPasExpr; out GUID: TGuid): boolean;
     // CustomData
     function GetElementData(El: TPasElementBase;
       DataClass: TPas2JsElementDataClass): TPas2JsElementData; virtual;
@@ -4174,7 +4175,7 @@ begin
 end;
 
 function TPas2JSResolver.GetAssignGUIDString(TypeEl: TPasRecordType;
-  Expr: TPasExpr; out GUID: TGUID): boolean;
+  Expr: TPasExpr; out GUID: TGuid): boolean;
 var
   Value: TResEvalValue;
   GUIDStr: String;
@@ -9784,23 +9785,60 @@ end;
 
 function TPasToJSConverter.ConvertRecordValues(El: TRecordValues;
   AContext: TConvertContext): TJSElement;
-
-Var
-  R :  TJSObjectLiteral;
-  I : Integer;
-  RVI : TRecordValuesItem;
-  rel : TJSObjectLiteralElement;
-
+var
+  ObjLit: TJSObjectLiteral;
+  i: Integer;
+  RecFields: TRecordValuesItemArray;
+  Field: PRecordValuesItem;
+  Ref: TResolvedReference;
+  Member: TPasVariable;
+  NewMemE: TJSNewMemberExpression;
+  aResolver: TPas2JSResolver;
+  ResolvedEl: TPasResolverResult;
+  RecType: TPasRecordType;
+  ok: Boolean;
+  ObjLitEl: TJSObjectLiteralElement;
 begin
-  R:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El));
-  For I:=0 to Length(El.Fields)-1 do
-    begin
-    RVI:=El.Fields[i];
-    Rel:=R.Elements.AddElement;
-    Rel.Name:=TJSString(RVI.Name);
-    Rel.Expr:=ConvertElement(RVI.ValueExp,AContext);
-    end;
-  Result:=R;
+  Result:=nil;
+  aResolver:=AContext.Resolver;
+  ok:=false;
+  try
+    if aResolver<>nil then
+      begin
+      // with resolver:  new TRecord({...})
+      aResolver.ComputeElement(El,ResolvedEl,[]);
+      if (ResolvedEl.BaseType<>btContext)
+          or (ResolvedEl.LoTypeEl.ClassType<>TPasRecordType) then
+        RaiseNotSupported(El,AContext,20180429210932);
+      RecType:=TPasRecordType(ResolvedEl.LoTypeEl);
+
+      NewMemE:=TJSNewMemberExpression(CreateElement(TJSNewMemberExpression,El));
+      Result:=NewMemE;
+      NewMemE.MExpr:=CreateReferencePathExpr(RecType,AContext);
+      ObjLit:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El));
+      NewMemE.AddArg(ObjLit);
+      end
+    else
+      begin
+      // without resolver: {...}
+      ObjLit:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El));
+      Result:=ObjLit;;
+      end;
+    RecFields:=El.Fields;
+    for i:=0 to length(RecFields)-1 do
+      begin
+      Field:=@RecFields[i];
+      Ref:=Field^.NameExp.CustomData as TResolvedReference;
+      Member:=Ref.Declaration as TPasVariable;
+      ObjLitEl:=ObjLit.Elements.AddElement;
+      ObjLitEl.Name:=TJSString(TransformVariableName(Member,AContext));
+      ObjLitEl.Expr:=CreateValInit(Member.VarType,Field^.ValueExp,Field^.NameExp,AContext);
+      end;
+    ok:=true;
+  finally
+    if not ok then
+      Result.Free;
+  end;
 end;
 
 function TPasToJSConverter.ConvertArrayValues(El: TArrayValues;
@@ -16132,31 +16170,38 @@ var
   NewMemE: TJSNewMemberExpression;
   aResolver: TPas2JSResolver;
   ObjLit: TJSObjectLiteral;
-  GUID: TGUID;
+  GUID: TGuid;
 begin
   Result:=nil;
-  NewMemE:=TJSNewMemberExpression(CreateElement(TJSNewMemberExpression,El));
-  try
-    NewMemE.MExpr:=CreateReferencePathExpr(aRecord,AContext);
-    if Expr<>nil then
+  if Expr<>nil then
+    begin
+    aResolver:=AContext.Resolver;
+    if aResolver<>nil then
       begin
-      aResolver:=AContext.Resolver;
-      if aResolver<>nil then
+      if aResolver.GetAssignGUIDString(aRecord,Expr,GUID) then
         begin
-        if aResolver.GetAssignGUIDString(aRecord,Expr,GUID) then
-          begin
-          ObjLit:=CreateGUIDObjLit(aRecord,GUID,El,AContext);
-          NewMemE.AddArg(ObjLit);
-          end;
+        // new TGuid({ D1:...})
+        ObjLit:=CreateGUIDObjLit(aRecord,GUID,El,AContext);
+        NewMemE:=TJSNewMemberExpression(CreateElement(TJSNewMemberExpression,El));
+        Result:=NewMemE;
+        NewMemE.MExpr:=CreateReferencePathExpr(aRecord,AContext);
+        NewMemE.AddArg(ObjLit);
+        exit;
         end;
-      if NewMemE.Args=nil then
-        RaiseNotSupported(Expr,AContext,20161024192747);
       end;
-    Result:=NewMemE;
-  finally
+    if Expr is TRecordValues then
+      // new TRecord({...})
+      Result:=ConvertRecordValues(TRecordValues(Expr),AContext);
     if Result=nil then
-      NewMemE.Free;
-  end;
+      RaiseNotSupported(Expr,AContext,20161024192747);
+    end
+  else
+    begin
+    // new TRecord()
+    NewMemE:=TJSNewMemberExpression(CreateElement(TJSNewMemberExpression,El));
+    Result:=NewMemE;
+    NewMemE.MExpr:=CreateReferencePathExpr(aRecord,AContext);
+    end;
 end;
 
 function TPasToJSConverter.CreateReferencePath(El: TPasElement;

packages/pastojs/tests/tcmodules.pas

@@ -370,7 +370,7 @@ type
     Procedure TestRecord_TypeCastJSValueToRecord;
     Procedure TestRecord_VariantFail;
     Procedure TestRecord_FieldArray;
-    // ToDo: const record
+    Procedure TestRecord_Const;
 
     // classes
     Procedure TestClass_TObjectDefaultConstructor;
@@ -624,7 +624,6 @@ type
     Procedure TestResourcestringProgram;
     Procedure TestResourcestringUnit;
     Procedure TestResourcestringImplementation;
-    // ToDo: in unit interface and implementation
 
     // Attributes
     Procedure TestAtributes_Ignore;
@@ -7980,6 +7979,86 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestRecord_Const;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TArrInt = array[3..4] of longint;',
+  '  TPoint = record x,y: longint; end;',
+  '  TRec = record',
+  '    i: longint;',
+  '    a: array of longint;',
+  '    s: array[1..2] of longint;',
+  '    m: array[1..2,3..4] of longint;',
+  '    p: TPoint;',
+  '  end;',
+  '  TPoints = array of TPoint;',
+  'const',
+  '  r: TRec = (',
+  '    i:1;',
+  '    a:(2,3);',
+  '    s:(4,5);',
+  '    m:( (11,12), (13,14) );',
+  '    p: (x:21; y:22)',
+  '  );',
+  '  p: TPoints = ( (x:1;y:2), (x:3;y:4) );',
+  'begin']);
+  ConvertProgram;
+  CheckSource('TestRecord_Const',
+    LinesToStr([ // statements
+    'this.TPoint = function (s) {',
+    '  if (s) {',
+    '    this.x = s.x;',
+    '    this.y = s.y;',
+    '  } else {',
+    '    this.x = 0;',
+    '    this.y = 0;',
+    '  };',
+    '  this.$equal = function (b) {',
+    '    return (this.x === b.x) && (this.y === b.y);',
+    '  };',
+    '};',
+    'this.TRec = function (s) {',
+    '  if (s) {',
+    '    this.i = s.i;',
+    '    this.a = s.a;',
+    '    this.s = s.s.slice(0);',
+    '    this.m = s.m.slice(0);',
+    '    this.p = new $mod.TPoint(s.p);',
+    '  } else {',
+    '    this.i = 0;',
+    '    this.a = [];',
+    '    this.s = rtl.arraySetLength(null, 0, 2);',
+    '    this.m = rtl.arraySetLength(null, 0, 2, 2);',
+    '    this.p = new $mod.TPoint();',
+    '  };',
+    '  this.$equal = function (b) {',
+    '    return (this.i === b.i) && ((this.a === b.a) && (rtl.arrayEq(this.s, b.s) && (rtl.arrayEq(this.m, b.m) && this.p.$equal(b.p))));',
+    '  };',
+    '};',
+    'this.r = new $mod.TRec({',
+    '  i: 1,',
+    '  a: [2, 3],',
+    '  s: [4, 5],',
+    '  m: [[11, 12], [13, 14]],',
+    '  p: new $mod.TPoint({',
+    '      x: 21,',
+    '      y: 22',
+    '    })',
+    '});',
+    'this.p = [new $mod.TPoint({',
+    '  x: 1,',
+    '  y: 2',
+    '}), new $mod.TPoint({',
+    '  x: 3,',
+    '  y: 4',
+    '})];',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestClass_TObjectDefaultConstructor;
 begin
   StartProgram(false);