pas2js: descend pascal class from jsfunction

git-svn-id: trunk@45700 -

packages/fcl-passrc/src/pasresolver.pp

@@ -28034,7 +28034,7 @@ var
 begin
   Result:=false;
   if aClass=nil then exit;
-  while (aClass<>nil) and aClass.IsExternal do
+  while aClass<>nil do
     begin
     if aClass.ExternalName=ExtName then exit(true);
     AncestorScope:=(aClass.CustomData as TPasClassScope).AncestorScope;

packages/pastojs/src/fppas2js.pp

@@ -2990,7 +2990,7 @@ begin
   if not aClass.IsExternal then exit;
   if aClass.Parent is TPasMembersType then
     exit; // nested class
-  if not IsExternalClass_Name(aClass,Data^.JSName) then exit;
+  if aClass.ExternalName<>Data^.JSName then exit;
   Data^.Found:=aClass;
   Data^.ElScope:=ElScope;
   Data^.StartScope:=StartScope;
@@ -4333,12 +4333,12 @@ begin
           okClass:
             begin
             if (ClassScope.NewInstanceFunction=nil)
+                and (Proc.ClassType=TPasClassFunction)
                 and (ClassScope.AncestorScope<>nil)
                 and (TPasClassType(ClassScope.AncestorScope.Element).IsExternal)
-                and (Proc.ClassType=TPasClassFunction)
                 and (Proc.Visibility in [visProtected,visPublic,visPublished])
                 and (TPasClassFunction(Proc).FuncType.ResultEl.ResultType=AClassOrRec)
-                and (Proc.Modifiers*[pmOverride,pmExternal]=[])
+                and (Proc.Modifiers-[pmVirtual,pmAssembler]=[])
                 and (Proc.ProcType.Modifiers*[ptmOfObject]=[ptmOfObject]) then
               begin
               // The first non private class function in a Pascal class descending
@@ -14374,7 +14374,7 @@ var
   AncestorPath, OwnerName, DestructorName, FnName, IntfKind: String;
   C: TClass;
   AssignSt: TJSSimpleAssignStatement;
-  NeedInitFunction, HasConstructor: Boolean;
+  NeedInitFunction, HasConstructor, IsJSFunction, NeedClassExt: Boolean;
   Proc: TPasProcedure;
   aResolver: TPas2JSResolver;
 begin
@@ -14419,11 +14419,17 @@ begin
   Call:=CreateCallExpression(El);
   try
     AncestorIsExternal:=(Ancestor is TPasClassType) and TPasClassType(Ancestor).IsExternal;
+    IsJSFunction:=aResolver.IsExternalClass_Name(El,'Function');
+
+    NeedClassExt:=AncestorIsExternal or IsJSFunction;
+    if NeedClassExt and (El.ObjKind<>okClass) then
+      RaiseNotSupported(El,AContext,20200627083750);
+
     if El.ObjKind=okInterface then
       FnName:=GetBIName(pbifnIntfCreate)
     else if El.ObjKind in okAllHelpers then
       FnName:=GetBIName(pbifnCreateHelper)
-    else if AncestorIsExternal then
+    else if NeedClassExt then
       FnName:=GetBIName(pbifnCreateClassExt)
     else
       FnName:=GetBIName(pbifnCreateClass);
@@ -14462,7 +14468,7 @@ begin
       AncestorPath:=CreateReferencePath(Ancestor,AContext,rpkPathAndName);
     Call.AddArg(CreatePrimitiveDotExpr(AncestorPath,El));
 
-    if AncestorIsExternal and (El.ObjKind=okClass) then
+    if NeedClassExt then
       begin
       // add the name of the NewInstance function
       if Scope.NewInstanceFunction<>nil then

packages/pastojs/tests/tcmodules.pas

@@ -609,6 +609,7 @@ type
     Procedure TestExternalClass_NewInstance_NonVirtualFail;
     Procedure TestExternalClass_NewInstance_FirstParamNotString_Fail;
     Procedure TestExternalClass_NewInstance_SecondParamTyped_Fail;
+    Procedure TestExternalClass_JSFunctionPasDescendant;
     Procedure TestExternalClass_PascalProperty;
     Procedure TestExternalClass_TypeCastToRootClass;
     Procedure TestExternalClass_TypeCastToJSObject;
@@ -17481,6 +17482,77 @@ begin
   ConvertProgram;
 end;
 
+procedure TTestModule.TestExternalClass_JSFunctionPasDescendant;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  TJSFunction = class external name ''Function''',
+  '  end;',
+  '  TExtA = class external name ''ExtA''(TJSFunction)',
+  '  end;',
+  '  TBird = class (TExtA)',
+  '  public',
+  '    Size: word;',
+  '    class var Legs: word;',
+  '    constructor Create(a: word);',
+  '  end;',
+  '  TEagle = class (TBird)',
+  '  public',
+  '    constructor Create(b: word); reintroduce;',
+  '  end;',
+  'constructor TBird.Create(a: word);',
+  'begin',
+  'end;',
+  'constructor TEagle.Create(b: word);',
+  'begin',
+  '  inherited Create(b);',
+  'end;',
+  'var',
+  '  Bird: TBird;',
+  '  Eagle: TEagle;',
+  'begin',
+  '  Bird:=TBird.Create(3);',
+  '  Eagle:=TEagle.Create(4);',
+  '  Bird.Size:=Bird.Size+5;',
+  '  Bird.Legs:=Bird.Legs+6;',
+  '  Eagle.Size:=Eagle.Size+5;',
+  '  Eagle.Legs:=Eagle.Legs+6;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestExternalClass_JSFunctionPasDescendant',
+    LinesToStr([ // statements
+    'rtl.createClassExt($mod, "TBird", ExtA, "", function () {',
+    '  this.Legs = 0;',
+    '  this.$init = function () {',
+    '    this.Size = 0;',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.Create = function (a) {',
+    '    return this;',
+    '  };',
+    '});',
+    'rtl.createClassExt($mod, "TEagle", $mod.TBird, "", function () {',
+    '  this.Create$1 = function (b) {',
+    '    $mod.TBird.Create.call(this, b);',
+    '    return this;',
+    '  };',
+    '});',
+    'this.Bird = null;',
+    'this.Eagle = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.Bird = $mod.TBird.$create("Create", [3]);',
+    '$mod.Eagle = $mod.TEagle.$create("Create$1", [4]);',
+    '$mod.Bird.Size = $mod.Bird.Size + 5;',
+    '$mod.TBird.Legs = $mod.Bird.Legs + 6;',
+    '$mod.Eagle.Size = $mod.Eagle.Size + 5;',
+    '$mod.TBird.Legs = $mod.Eagle.Legs + 6;',
+    '']));
+end;
+
 procedure TTestModule.TestExternalClass_PascalProperty;
 begin
   StartProgram(false);

utils/pas2js/dist/rtl.js

@@ -347,34 +347,41 @@ var rtl = {
     // Create a class using an external ancestor.
     // If newinstancefnname is given, use that function to create the new object.
     // If exist call BeforeDestruction and AfterConstruction.
-    var c = Object.create(ancestor);
+    var isFunc = rtl.isFunction(ancestor);
+    var c = null;
+    if (isFunc){
+      // create pascal class descendent from JS function
+      c = Object.create(ancestor.prototype);
+    } else if (ancestor.$func){
+      // create pascal class descendent from a pascal class descendent of a JS function
+      isFunc = true;
+      c = Object.create(ancestor);
+      c.$ancestor = ancestor;
+    } else {
+      c = Object.create(ancestor);
+    }
     c.$create = function(fn,args){
       if (args == undefined) args = [];
       var o = null;
       if (newinstancefnname.length>0){
         o = this[newinstancefnname](fn,args);
-        if (!o.$class){
-          o.$class = this;
-          o.$classname = this.$classname;
-          o.$name = this.$name;
-          o.$fullname = this.$fullname;
-          o.$ancestor = this.$ancestor;
-        }
+      } else if(isFunc) {
+        o = new c.$func(args);
       } else {
-        o = Object.create(this);
+        o = Object.create(c);
       }
-      if (this.$init) this.$init.call(o);
+      if (o.$init) o.$init();
       try{
         if (typeof(fn)==="string"){
           this[fn].apply(o,args);
         } else {
           fn.apply(o,args);
         };
-        if (this.AfterConstruction) this.call.AfterConstruction(o);
+        if (o.AfterConstruction) o.AfterConstruction();
       } catch($e){
         // do not call BeforeDestruction
-        if (this.Destroy) this.Destroy.call(o);
-        if (this.$final) this.$final.call(o);
+        if (o.Destroy) o.Destroy();
+        if (o.$final) o.$final();
         throw $e;
       }
       return o;
@@ -385,6 +392,11 @@ var rtl = {
       if (this.$final) this.$final();
     };
     rtl.initClass(c,parent,name,initfn);
+    if (isFunc){
+      function f(){}
+      f.prototype = c;
+      c.$func = f;
+    }
   },
 
   createHelper: function(parent,name,ancestor,initfn){