pastojs: mark NewInstance function as used

git-svn-id: trunk@41825 -

packages/pastojs/src/pas2jsuseanalyzer.pp

@@ -13,8 +13,13 @@
 
  **********************************************************************
 
-  Abstract:
-    Extends the FCL Pascal use analyzer for the language subset of pas2js.
+Abstract:
+  Extends the FCL Pascal use analyzer for the language subset of pas2js.
+
+Works:
+- Array of Const marks function System.VarRecs()
+- TPascalDescendantOfExt.Create marks class method NewInstance
+
 }
 unit Pas2jsUseAnalyzer;
 
@@ -35,6 +40,7 @@ type
   TPas2JSAnalyzer = class(TPasAnalyzer)
   public
     procedure UseExpr(El: TPasExpr); override;
+    procedure UseConstructor(Proc: TPasConstructor; PosEl: TPasElement); virtual;
   end;
 
 implementation
@@ -86,11 +92,35 @@ begin
     Ref:=TResolvedReference(El.CustomData);
     Decl:=Ref.Declaration;
     if Decl is TPasProcedure then
-      CheckArgs(TPasProcedure(Decl).ProcType.Args)
+      begin
+      CheckArgs(TPasProcedure(Decl).ProcType.Args);
+      if Decl.ClassType=TPasConstructor then
+        UseConstructor(TPasConstructor(Decl),El);
+      end
     else if Decl.ClassType=TPasProperty then
       CheckArgs(Resolver.GetPasPropertyArgs(TPasProperty(Decl)));
     end;
 end;
 
+procedure TPas2JSAnalyzer.UseConstructor(Proc: TPasConstructor;
+  PosEl: TPasElement);
+var
+  ClassScope: TPas2JSClassScope;
+begin
+  if Proc.Parent.ClassType=TPasClassType then
+    begin
+    ClassScope:=TPasClassType(Proc.Parent).CustomData as TPas2JSClassScope;
+    repeat
+      if ClassScope.NewInstanceFunction<>nil then
+        begin
+        UseProcedure(ClassScope.NewInstanceFunction);
+        break;
+        end;
+      ClassScope:=ClassScope.AncestorScope as TPas2JSClassScope;
+    until ClassScope=nil;
+    end;
+  if PosEl=nil then ;
+end;
+
 end.
 

packages/pastojs/tests/tcoptimizations.pas

@@ -76,6 +76,7 @@ type
     procedure TestWPO_Class_OmitPropertyGetter2;
     procedure TestWPO_Class_OmitPropertySetter1;
     procedure TestWPO_Class_OmitPropertySetter2;
+    procedure TestWPO_Class_KeepNewInstance;
     procedure TestWPO_CallInherited;
     procedure TestWPO_UseUnit;
     procedure TestWPO_ArrayOfConst_Use;
@@ -724,6 +725,56 @@ begin
     '']));
 end;
 
+procedure TTestOptimizations.TestWPO_Class_KeepNewInstance;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  TExt = class external name ''Object''',
+  '  end;',
+  '  TBird = class(TExt)',
+  '  protected',
+  '    class function NewInstance(fnname: string; const paramarray): TBird; virtual;',
+  '  public',
+  '    constructor Create;',
+  '  end;',
+  'class function TBird.NewInstance(fnname: string; const paramarray): TBird;',
+  'begin',
+  '  asm',
+  '  Result = Object.create();',
+  '  end;',
+  'end;',
+  'constructor TBird.Create;',
+  'begin',
+  '  inherited;',
+  'end;',
+  'begin',
+  '  TBird.Create;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestWPO_Class_KeepNewInstance',
+    LinesToStr([
+    'rtl.createClassExt($mod, "TBird", Object, "NewInstance", function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.NewInstance = function (fnname, paramarray) {',
+    '    var Result = null;',
+    '    Result = Object.create();',
+    '    return Result;',
+    '  };',
+    '  this.Create = function () {',
+    '    return this;',
+    '  };',
+    '});',
+    '']),
+    LinesToStr([
+    '$mod.TBird.$create("Create");',
+    '']));
+end;
+
 procedure TTestOptimizations.TestWPO_CallInherited;
 begin
   StartProgram(false);

packages/pastojs/tests/testpas2js.lpi

@@ -1,6 +1,6 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
-  <ProjectOptions BuildModesCount="1">
+  <ProjectOptions>
     <Version Value="12"/>
     <General>
       <Flags>
@@ -17,8 +17,8 @@
     <i18n>
       <EnableI18N LFM="False"/>
     </i18n>
-    <BuildModes>
-      <Item1 Name="Default" Default="True"/>
+    <BuildModes Count="1">
+      <Item1 Name="default" Default="True"/>
     </BuildModes>
     <PublishOptions>
       <Version Value="2"/>