diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 9c12a46519..47161b03f3 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/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 diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 56aa075b74..d9f646071e 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/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:=aExt + else + begin + Result:=cIncompatible; + break; + end; + end; + end; + end; +end; + function TPas2JSResolver.HasStaticArrayCloneFunc(Arr: TPasArrayType): boolean; var l: Integer; diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas index acff8b89b7..bd44bc33f9 100644 --- a/packages/pastojs/tests/tcgenerics.pas +++ b/packages/pastojs/tests/tcgenerics.pas @@ -39,8 +39,7 @@ type // generic external class procedure TestGen_ExtClass_Array; - // ToDo: TestGen_ExtClass_GenJSValueAssign TExt := TExt - // ToDo: TestGen_ExtClass_TypeCastJSValue TExt(aTExt) 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 = class external name ''Ext''', + ' F: T;', + ' end;', + ' TExtWord = TExt;', + ' TExtAny = TExt;', + '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);