pas2js: allow ExtClass<JSValue>:=ExtClass<Word>

git-svn-id: trunk@44173 -

packages/fcl-passrc/src/pasresolver.pp

@@ -2226,6 +2226,7 @@ type
       const ResolvedSrcType, ResolvedDestType: TPasResolverResult): integer;
     function CheckClassIsClass(SrcType, DestType: TPasType): integer; virtual;
     function CheckClassesAreRelated(TypeA, TypeB: TPasType): integer;
+    function CheckAssignCompatibilityClasses(LType, RType: TPasClassType): integer; virtual; // not related classes
     function GetClassImplementsIntf(ClassEl, Intf: TPasClassType): TPasClassType;
     function CheckProcOverloadCompatibility(Proc1, Proc2: TPasProcedure): boolean;
     function CheckProcTypeCompatibility(Proc1, Proc2: TPasProcedureType;
@@ -25283,6 +25284,7 @@ var
   LArray, RArray: TPasArrayType;
   GotDesc, ExpDesc: String;
   CurTVarRec: TPasRecordType;
+  LeftClass, RightClass: TPasClassType;
 
   function RaiseIncompatType(Id: TMaxPrecInt): integer;
   begin
@@ -25316,18 +25318,22 @@ begin
       Result:=cIncompatible;
       if not (rrfReadable in RHS.Flags) then
         exit(RaiseIncompatType(20190215112914));
-      if TPasClassType(LTypeEl).ObjKind=TPasClassType(RTypeEl).ObjKind then
+      LeftClass:=TPasClassType(LTypeEl);
+      RightClass:=TPasClassType(RTypeEl);
+      if LeftClass.ObjKind=RightClass.ObjKind then
         Result:=CheckSrcIsADstType(RHS,LHS)
-      else if TPasClassType(LTypeEl).ObjKind=okInterface then
+      else if LeftClass.ObjKind=okInterface then
         begin
-        if (TPasClassType(RTypeEl).ObjKind=okClass)
-            and (not TPasClassType(RTypeEl).IsExternal) then
+        if (RightClass.ObjKind=okClass)
+            and (not RightClass.IsExternal) then
           begin
           // IntfVar:=ClassInstVar
-          if GetClassImplementsIntf(TPasClassType(RTypeEl),TPasClassType(LTypeEl))<>nil then
+          if GetClassImplementsIntf(RightClass,LeftClass)<>nil then
             exit(cTypeConversion);
           end;
         end;
+      if Result=cIncompatible then
+        Result:=CheckAssignCompatibilityClasses(LeftClass,RightClass);
       if (Result=cIncompatible) and RaiseOnIncompatible then
         RaiseIncompatibleType(20170216152458,nIncompatibleTypesGotExpected,
           [],RTypeEl,LTypeEl,ErrorEl);
@@ -28856,6 +28862,14 @@ begin
   Result:=CheckClassIsClass(TypeB,TypeA);
 end;
 
+function TPasResolver.CheckAssignCompatibilityClasses(LType,
+  RType: TPasClassType): integer;
+begin
+  Result:=cIncompatible;
+  if LType=nil then ;
+  if RType=nil then ;
+end;
+
 function TPasResolver.GetClassImplementsIntf(ClassEl, Intf: TPasClassType
   ): TPasClassType;
 begin

packages/pastojs/src/fppas2js.pp

@@ -1433,6 +1433,8 @@ type
     procedure CheckAssignExprRangeToCustom(
       const LeftResolved: TPasResolverResult; RValue: TResEvalValue;
       RHS: TPasExpr); override;
+    function CheckAssignCompatibilityClasses(LType, RType: TPasClassType
+      ): integer; override;
     function HasStaticArrayCloneFunc(Arr: TPasArrayType): boolean;
     function IsTGUID(TypeEl: TPasRecordType): boolean; override;
     function GetAssignGUIDString(TypeEl: TPasRecordType; Expr: TPasExpr; out GUID: TGuid): boolean;
@@ -5679,6 +5681,43 @@ begin
   if RValue=nil then ;
 end;
 
+function TPas2JSResolver.CheckAssignCompatibilityClasses(LType,
+  RType: TPasClassType): integer;
+// LType and RType are not related
+var
+  LeftScope, RightScope: TPas2JSClassScope;
+  LeftSpecItem, RightSpecItem: TPRSpecializedItem;
+  i: Integer;
+  LeftParam, RightParam: TPasType;
+begin
+  Result:=cIncompatible;
+  if LType.IsExternal and RType.IsExternal then
+    begin
+    LeftScope:=TPas2JSClassScope(LType.CustomData);
+    RightScope:=TPas2JSClassScope(RType.CustomData);
+    LeftSpecItem:=LeftScope.SpecializedFromItem;
+    RightSpecItem:=RightScope.SpecializedFromItem;
+    if (LeftSpecItem<>nil) and (RightSpecItem<>nil)
+        and (LeftSpecItem.GenericEl=RightSpecItem.GenericEl) then
+      begin
+      Result:=cExact;
+      for i:=0 to length(LeftSpecItem.Params)-1 do
+        begin
+        LeftParam:=LeftSpecItem.Params[i];
+        RightParam:=RightSpecItem.Params[i];
+        if IsSameType(LeftParam,RightParam,prraAlias)
+            or IsJSBaseType(LeftParam,pbtJSValue) then
+          // e.g. TExt<jsvalue>:=aExt<word>
+        else
+          begin
+          Result:=cIncompatible;
+          break;
+          end;
+        end;
+      end;
+    end;
+end;
+
 function TPas2JSResolver.HasStaticArrayCloneFunc(Arr: TPasArrayType): boolean;
 var
   l: Integer;

packages/pastojs/tests/tcgenerics.pas

@@ -39,8 +39,7 @@ type
 
     // generic external class
     procedure TestGen_ExtClass_Array;
-    // ToDo: TestGen_ExtClass_GenJSValueAssign  TExt<JSValue> := TExt<Word>
-    // ToDo: TestGen_ExtClass_TypeCastJSValue  TExt<Word>(aTExt<JSValue>) and vice versa
+    procedure TestGen_ExtClass_GenJSValueAssign;
 
     // statements
     Procedure TestGen_InlineSpec_Constructor;
@@ -786,6 +785,42 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_ExtClass_GenJSValueAssign;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  '{$modeswitch externalclass}',
+  'type',
+  '  TExt<T> = class external name ''Ext''',
+  '    F: T;',
+  '  end;',
+  '  TExtWord = TExt<Word>;',
+  '  TExtAny = TExt<JSValue>;',
+  'procedure Run(e: TExtAny);',
+  'begin end;',
+  'var',
+  '  w: TExtWord;',
+  '  a: TExtAny;',
+  'begin',
+  '  a:=w;',
+  '  Run(w);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_ExtClass_GenJSValueAssign',
+    LinesToStr([ // statements
+    'this.Run = function (e) {',
+    '};',
+    'this.w = null;',
+    'this.a = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.a = $mod.w;',
+    '$mod.Run($mod.w);',
+    '']));
+  CheckResolverUnexpectedHints();
+end;
+
 procedure TTestGenerics.TestGen_InlineSpec_Constructor;
 begin
   StartProgram(false);