paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-25 02:22:49 +01:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: trunk@44173 -
This commit is contained in:
Mattias Gaertner 2020-02-14 17:05:14 +00:00
parent c4f3f7f453
commit bde36ab7a0
3 changed files with 95 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
packages/fcl-passrc/src/pasresolver.pp
View File

@ -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

39
packages/pastojs/src/fppas2js.pp
View File

@ -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;

39
packages/pastojs/tests/tcgenerics.pas
View File

@ -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);