pastojs: test wpo in other unit

git-svn-id: trunk@38472 -

packages/pastojs/tests/tcmodules.pas

@@ -3226,29 +3226,30 @@ end;
 procedure TTestModule.TestProc_Varargs;
 begin
   StartProgram(false);
-  Add('procedure ProcA(i:longint); varargs; external name ''ProcA'';');
-  Add('procedure ProcB; varargs; external name ''ProcB'';');
-  Add('procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';');
-  Add('function GetIt: longint; begin end;');
-  Add('begin');
-  Add('  ProcA(1);');
-  Add('  ProcA(1,2);');
-  Add('  ProcA(1,2.0);');
-  Add('  ProcA(1,2,3);');
-  Add('  ProcA(1,''2'');');
-  Add('  ProcA(2,'''');');
-  Add('  ProcA(3,false);');
-  Add('  ProcB;');
-  Add('  ProcB();');
-  Add('  ProcB(4);');
-  Add('  ProcB(''foo'');');
-  Add('  ProcC;');
-  Add('  ProcC();');
-  Add('  ProcC(4);');
-  Add('  ProcC(5,''foo'');');
-  Add('  ProcB(GetIt);');
-  Add('  ProcB(GetIt());');
-  Add('  ProcB(GetIt,GetIt());');
+  Add([
+  'procedure ProcA(i:longint); varargs; external name ''ProcA'';',
+  'procedure ProcB; varargs; external name ''ProcB'';',
+  'procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';',
+  'function GetIt: longint; begin end;',
+  'begin',
+  '  ProcA(1);',
+  '  ProcA(1,2);',
+  '  ProcA(1,2.0);',
+  '  ProcA(1,2,3);',
+  '  ProcA(1,''2'');',
+  '  ProcA(2,'''');',
+  '  ProcA(3,false);',
+  '  ProcB;',
+  '  ProcB();',
+  '  ProcB(4);',
+  '  ProcB(''foo'');',
+  '  ProcC;',
+  '  ProcC();',
+  '  ProcC(4);',
+  '  ProcC(5,''foo'');',
+  '  ProcB(GetIt);',
+  '  ProcB(GetIt());',
+  '  ProcB(GetIt,GetIt());']);
   ConvertProgram;
   CheckSource('TestProc_Varargs',
     LinesToStr([ // statements
@@ -6916,18 +6917,19 @@ end;
 procedure TTestModule.TestExternalClass_TypeCastArrayToExternalArray;
 begin
   StartProgram(false);
-  Add('{$modeswitch externalclass}');
-  Add('type');
-  Add('  TJSArray = class external name ''Array''');
-  Add('    class function isArray(Value: JSValue) : boolean;');
-  Add('    function concat() : TJSArray; varargs;');
-  Add('  end;');
-  Add('var');
-  Add('  aObj: TJSArray;');
-  Add('  a: array of longint;');
-  Add('begin');
-  Add('  if TJSArray.isArray(65) then ;');
-  Add('  aObj:=TJSArray(a).concat(a);');
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  TJSArray = class external name ''Array''',
+  '    class function isArray(Value: JSValue) : boolean;',
+  '    function concat() : TJSArray; varargs;',
+  '  end;',
+  'var',
+  '  aObj: TJSArray;',
+  '  a: array of longint;',
+  'begin',
+  '  if TJSArray.isArray(65) then ;',
+  '  aObj:=TJSArray(a).concat(a);']);
   ConvertProgram;
   CheckSource('TestExternalClass_TypeCastArrayToExternalArray',
     LinesToStr([ // statements

packages/pastojs/tests/tcoptimizations.pas

@@ -44,6 +44,7 @@ type
     procedure TearDown; override;
     procedure ParseModule; override;
     procedure ParseProgram; override;
+    function CreateConverter: TPasToJSConverter; override;
   public
     property AnalyzerModule: TPasAnalyzer read FAnalyzerModule;
     property AnalyzerProgram: TPasAnalyzer read FAnalyzerProgram;
@@ -67,15 +68,17 @@ type
     procedure TestWPO_OmitRecordMember;
     procedure TestWPO_OmitNotUsedTObject;
     procedure TestWPO_TObject;
-    procedure TestWPO_OmitClassField;
-    procedure TestWPO_OmitClassMethod;
-    procedure TestWPO_OmitClassClassMethod;
-    procedure TestWPO_OmitPropertyGetter1;
-    procedure TestWPO_OmitPropertyGetter2;
-    procedure TestWPO_OmitPropertySetter1;
-    procedure TestWPO_OmitPropertySetter2;
+    procedure TestWPO_Class_Property;
+    procedure TestWPO_Class_OmitField;
+    procedure TestWPO_Class_OmitMethod;
+    procedure TestWPO_Class_OmitClassMethod;
+    procedure TestWPO_Class_OmitPropertyGetter1;
+    procedure TestWPO_Class_OmitPropertyGetter2;
+    procedure TestWPO_Class_OmitPropertySetter1;
+    procedure TestWPO_Class_OmitPropertySetter2;
     procedure TestWPO_CallInherited;
     procedure TestWPO_UseUnit;
+    procedure TestWPO_Class_PropertyInOtherUnit;
     procedure TestWPO_ProgramPublicDeclaration;
     procedure TestWPO_ConstructorDefaultValueConst;
     procedure TestWPO_RTTI_PublishedField;
@@ -93,8 +96,15 @@ var
 begin
   if WholeProgramOptimization then
     A:=AnalyzerProgram
+  else if Sender=Converter then
+    A:=AnalyzerModule
   else
-    A:=AnalyzerModule;
+    begin
+    {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
+    writeln('TCustomTestOptimizations.OnConverterIsElementUsed El=',GetObjName(El),' WPO=',WholeProgramOptimization,' Sender=',GetObjName(Sender));
+    {$ENDIF}
+    Fail('converting other unit without WPO');
+    end;
   Result:=A.IsUsed(El);
   {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
   writeln('TCustomTestOptimizations.OnConverterIsElementUsed El=',GetObjName(El),' WPO=',WholeProgramOptimization,' Result=',Result);
@@ -108,8 +118,15 @@ var
 begin
   if WholeProgramOptimization then
     A:=AnalyzerProgram
+  else if Sender=Converter then
+    A:=AnalyzerModule
   else
-    A:=AnalyzerModule;
+    begin
+    {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
+    writeln('TCustomTestOptimizations.OnConverterIsTypeInfoUsed El=',GetObjName(El),' WPO=',WholeProgramOptimization,' Sender=',GetObjName(Sender));
+    {$ENDIF}
+    Fail('converting other unit without WPO');
+    end;
   Result:=A.IsTypeInfoUsed(El);
   {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
   writeln('TCustomTestOptimizations.OnConverterIsTypeInfoUsed El=',GetObjName(El),' WPO=',WholeProgramOptimization,' Result=',Result);
@@ -124,8 +141,6 @@ begin
   FAnalyzerModule.Resolver:=Engine;
   FAnalyzerProgram:=TPasAnalyzer.Create;
   FAnalyzerProgram.Resolver:=Engine;
-  Converter.OnIsElementUsed:=@OnConverterIsElementUsed;
-  Converter.OnIsTypeInfoUsed:=@OnConverterIsTypeInfoUsed;
 end;
 
 procedure TCustomTestOptimizations.TearDown;
@@ -160,6 +175,13 @@ begin
   {$ENDIF}
 end;
 
+function TCustomTestOptimizations.CreateConverter: TPasToJSConverter;
+begin
+  Result:=inherited CreateConverter;
+  Result.OnIsElementUsed:=@OnConverterIsElementUsed;
+  Result.OnIsTypeInfoUsed:=@OnConverterIsTypeInfoUsed;
+end;
+
 { TTestOptimizations }
 
 procedure TTestOptimizations.TestWPO_OmitLocalVar;
@@ -429,7 +451,49 @@ begin
     '$mod.o = null;']));
 end;
 
-procedure TTestOptimizations.TestWPO_OmitClassField;
+procedure TTestOptimizations.TestWPO_Class_Property;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  private',
+  '    const CA = 3;',
+  '  private',
+  '    FA: longint;',
+  '    function GetA: longint;',
+  '    procedure SetA(Value: longint);',
+  '    function IsStoredA: boolean;',
+  '    property A: longint read GetA write SetA stored IsStoredA default CA;',
+  '  end;',
+  'function tobject.geta: longint; begin end;',
+  'procedure tobject.seta(value: longint); begin end;',
+  'function tobject.isstoreda: boolean; begin end;',
+  'var o: TObject;',
+  'begin',
+  '  o.A:=o.A;']);
+  ConvertProgram;
+  CheckSource('TestWPO_Class_TObject',
+    LinesToStr([
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.GetA = function () {',
+    '    var Result = 0;',
+    '    return Result;',
+    '  };',
+    '  this.SetA = function (Value) {',
+    '  };',
+    '});',
+    'this.o = null;',
+    '']),
+    LinesToStr([
+    '$mod.o.SetA($mod.o.GetA());']));
+end;
+
+procedure TTestOptimizations.TestWPO_Class_OmitField;
 begin
   StartProgram(false);
   Add('type');
@@ -456,7 +520,7 @@ begin
     '$mod.o.a = 3;']));
 end;
 
-procedure TTestOptimizations.TestWPO_OmitClassMethod;
+procedure TTestOptimizations.TestWPO_Class_OmitMethod;
 begin
   StartProgram(false);
   Add('type');
@@ -486,7 +550,7 @@ begin
     '$mod.o.ProcB();']));
 end;
 
-procedure TTestOptimizations.TestWPO_OmitClassClassMethod;
+procedure TTestOptimizations.TestWPO_Class_OmitClassMethod;
 begin
   StartProgram(false);
   Add('type');
@@ -516,7 +580,7 @@ begin
     '$mod.o.$class.ProcB();']));
 end;
 
-procedure TTestOptimizations.TestWPO_OmitPropertyGetter1;
+procedure TTestOptimizations.TestWPO_Class_OmitPropertyGetter1;
 begin
   StartProgram(false);
   Add('type');
@@ -552,7 +616,7 @@ begin
     '']));
 end;
 
-procedure TTestOptimizations.TestWPO_OmitPropertyGetter2;
+procedure TTestOptimizations.TestWPO_Class_OmitPropertyGetter2;
 begin
   StartProgram(false);
   Add('type');
@@ -588,7 +652,7 @@ begin
     '']));
 end;
 
-procedure TTestOptimizations.TestWPO_OmitPropertySetter1;
+procedure TTestOptimizations.TestWPO_Class_OmitPropertySetter1;
 begin
   StartProgram(false);
   Add('type');
@@ -624,7 +688,7 @@ begin
     '']));
 end;
 
-procedure TTestOptimizations.TestWPO_OmitPropertySetter2;
+procedure TTestOptimizations.TestWPO_Class_OmitPropertySetter2;
 begin
   StartProgram(false);
   Add('type');
@@ -750,6 +814,63 @@ begin
   CheckDiff('TestWPO_UseUnit',ExpectedSrc,ActualSrc);
 end;
 
+procedure TTestOptimizations.TestWPO_Class_PropertyInOtherUnit;
+begin
+  AddModuleWithIntfImplSrc('unit1.pp',
+    LinesToStr([
+    'type',
+    '  TObject = class',
+    '  private',
+    '    const CA = 3;',
+    '  private',
+    '    FOther: string;',
+    '    FA: longint;',
+    '    function GetA: longint;',
+    '    procedure SetA(Value: longint);',
+    '    function IsStoredA: boolean;',
+    '  public',
+    '    property A: longint read GetA write SetA stored IsStoredA default CA;',
+    '  end;',
+    '']),
+    LinesToStr([
+    'function TObject.geta: longint;',
+    'begin',
+    'end;',
+    'procedure TObject.seta(value: longint);',
+    'begin',
+    '  FA:=Value;',
+    'end;',
+    'function TObject.isstoreda: boolean; begin end;',
+    '']));
+  StartProgram(true);
+  Add([
+  'uses unit1;',
+  'var o: TObject;',
+  'begin',
+  '  o.A:=o.A;']);
+  ConvertProgram;
+  CheckUnit('unit1.pp',
+  LinesToStr([
+  'rtl.module("unit1", ["system"], function () {',
+  '  var $mod = this;',
+  '  rtl.createClass($mod, "TObject", null, function () {',
+  '    this.$init = function () {',
+  '      this.FA = 0;',
+  '    };',
+  '    this.$final = function () {',
+  '    };',
+  '    this.GetA = function () {',
+  '      var Result = 0;',
+  '      return Result;',
+  '    };',
+  '    this.SetA = function (Value) {',
+  '      this.FA = Value;',
+  '    };',
+  '  });',
+  '});',
+  '']));
+end;
+
 procedure TTestOptimizations.TestWPO_ProgramPublicDeclaration;
 var
   ActualSrc, ExpectedSrc: String;