Răsfoiți Sursa

pastojs: rtti flag for class property

mattias 5 luni în urmă
părinte
comite
00ed18a61b
2 a modificat fișierele cu 62 adăugiri și 0 ștergeri
  1. 3 0
      packages/pastojs/src/fppas2js.pp
  2. 59 0
      packages/pastojs/tests/tcmodules.pas

+ 3 - 0
packages/pastojs/src/fppas2js.pp

@@ -2385,6 +2385,7 @@ type
       pfStoredFunction = 12; // stored function, function name is in Stored
       pfStoredFunction = 12; // stored function, function name is in Stored
       pfHasIndex = 16; { if getter is function, append Index as last param
       pfHasIndex = 16; { if getter is function, append Index as last param
                          if setter is function, append Index as second last param }
                          if setter is function, append Index as second last param }
+      pfClassProperty = 32;  // class property
     type
     type
       TMethodKind = (
       TMethodKind = (
         mkProcedure,      // 0  default
         mkProcedure,      // 0  default
@@ -21127,6 +21128,8 @@ begin
           inc(Flags,pfStoredField);
           inc(Flags,pfStoredField);
         end;
         end;
       end;
       end;
+    if Prop.IsClass then
+      inc(Flags,pfClassProperty);
     Call.AddArg(CreateLiteralNumber(Prop,Flags));
     Call.AddArg(CreateLiteralNumber(Prop,Flags));
 
 
     // add type
     // add type

+ 59 - 0
packages/pastojs/tests/tcmodules.pas

@@ -886,6 +886,7 @@ type
     Procedure TestRTTI_Class_Property;
     Procedure TestRTTI_Class_Property;
     Procedure TestRTTI_Class_PropertyParams;
     Procedure TestRTTI_Class_PropertyParams;
     Procedure TestRTTI_Class_PropertyPrivate;
     Procedure TestRTTI_Class_PropertyPrivate;
+    Procedure TestRTTI_Class_ClassProperty;
     Procedure TestRTTI_Class_OtherUnit_TypeAlias;
     Procedure TestRTTI_Class_OtherUnit_TypeAlias;
     Procedure TestRTTI_Class_OmitRTTI;
     Procedure TestRTTI_Class_OmitRTTI;
     Procedure TestRTTI_Class_Field_AnonymousArrayOfSelfClass;
     Procedure TestRTTI_Class_Field_AnonymousArrayOfSelfClass;
@@ -32064,6 +32065,64 @@ begin
     '']));
     '']));
 end;
 end;
 
 
+procedure TTestModule.TestRTTI_Class_ClassProperty;
+begin
+  WithTypeInfo:=true;
+  StartProgram(false);
+  Add('type');
+  Add('{$RTTI explicit properties([vcPrivate,vcProtected,vcPublic,vcPublished])}');
+  Add('  TObject = class');
+  Add('  private');
+  Add('    class var FWord: word;');
+  Add('    class function GetWord: word; virtual; abstract;');
+  Add('    class procedure SetWord(Value: word); virtual; abstract;');
+  Add('    class property PrivateWord: word read FWord write FWord;');
+  Add('  protected');
+  Add('    class property ProtectedWord: word read FWord write SetWord;');
+  Add('  public');
+  Add('    class property PublicWord: word read GetWord;');
+  Add('  end;');
+  Add('begin');
+  ConvertProgram;
+  CheckSource('TestRTTI_Class_ClassProperty',
+    LinesToStr([ // statements
+    'rtl.createClass(this, "TObject", null, function () {',
+    '  this.FWord = 0;',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  var $r = this.$rtti;',
+    '  $r.addProperty(',
+    '    "PrivateWord",',
+    '    32,',
+    '    rtl.word,',
+    '    "FWord",',
+    '    "FWord",',
+    '    0',
+    '  );',
+    '  $r.addProperty(',
+    '    "ProtectedWord",',
+    '    34,',
+    '    rtl.word,',
+    '    "FWord",',
+    '    "SetWord",',
+    '    1',
+    '  );',
+    '  $r.addProperty(',
+    '    "PublicWord",',
+    '    33,',
+    '    rtl.word,',
+    '    "GetWord",',
+    '    "",',
+    '    2',
+    '  );',
+    '});',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestRTTI_Class_OtherUnit_TypeAlias;
 procedure TTestModule.TestRTTI_Class_OtherUnit_TypeAlias;
 begin
 begin
   WithTypeInfo:=true;
   WithTypeInfo:=true;