diff --git a/compiler/packages/pastojs/src/pas2jsuseanalyzer.pp b/compiler/packages/pastojs/src/pas2jsuseanalyzer.pp index fd78ef8..860f731 100644 --- a/compiler/packages/pastojs/src/pas2jsuseanalyzer.pp +++ b/compiler/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. diff --git a/compiler/packages/pastojs/tests/tcoptimizations.pas b/compiler/packages/pastojs/tests/tcoptimizations.pas index 5911171..8909648 100644 --- a/compiler/packages/pastojs/tests/tcoptimizations.pas +++ b/compiler/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); diff --git a/compiler/packages/pastojs/tests/testpas2js.lpi b/compiler/packages/pastojs/tests/testpas2js.lpi index 2b73f4a..dd67c09 100644 --- a/compiler/packages/pastojs/tests/testpas2js.lpi +++ b/compiler/packages/pastojs/tests/testpas2js.lpi @@ -1,6 +1,6 @@ - + @@ -17,8 +17,8 @@ - - + +