From 94cee0dc3956cf80bb4b65b15ca0525a6979a6c5 Mon Sep 17 00:00:00 2001 From: mattias Date: Sun, 27 Dec 2020 20:52:16 +0000 Subject: [PATCH] fcl-passrc: check class intf impl proc type modifiers match --- .../packages/fcl-passrc/src/pasresolver.pp | 43 ++++++++++------ .../fcl-passrc/tests/tcresolvegenerics.pas | 2 +- compiler/packages/pastojs/tests/tcmodules.pas | 51 +++++++++++++++++++ 3 files changed, 79 insertions(+), 17 deletions(-) diff --git a/compiler/packages/fcl-passrc/src/pasresolver.pp b/compiler/packages/fcl-passrc/src/pasresolver.pp index a4d6a8b..2bc195b 100644 --- a/compiler/packages/fcl-passrc/src/pasresolver.pp +++ b/compiler/packages/fcl-passrc/src/pasresolver.pp @@ -1710,7 +1710,8 @@ type function CreateClassIntfMap(El: TPasClassType; Index: integer): TPasClassIntfMap; procedure CheckConditionExpr(El: TPasExpr; const ResolvedEl: TPasResolverResult); virtual; procedure CheckProcSignatureMatch(DeclProc, ImplProc: TPasProcedure; - IsOverride: boolean); + IsOverride: boolean // override or class intf implementation + ); procedure CheckPointerCycle(El: TPasPointerType); procedure CheckGenericTemplateTypes(El: TPasGenericType); virtual; procedure ComputeUnaryNot(El: TUnaryExpr; var ResolvedEl: TPasResolverResult; @@ -6453,6 +6454,10 @@ begin RaiseMsg(20180322143202,nNoMatchingImplForIntfMethodXFound, sNoMatchingImplForIntfMethodXFound, [GetProcTypeDescription(IntfProc.ProcType,[prptdUseName,prptdAddPaths,prptdResolveSimpleAlias])],El); // ToDo: jump to interface list + // check calling conventions + //writeln('TPasResolver.FinishClassType Intf=',GetObjPath(IntfProc),' Found=',GetObjPath(FindData.Found)); + CheckProcSignatureMatch(IntfProc,TPasProcedure(FindData.Found),true); + Map.Procs[j]:=FindData.Found; end; Map:=Map.AncestorMap; @@ -9396,7 +9401,7 @@ var DeclName, ImplName: String; ImplResult, DeclResult: TPasType; ImplTemplType, DeclTemplType: TPasGenericTemplateType; - NewImplPTMods: TProcTypeModifiers; + NewImplPTMods, DeclPTMods, ImplPTMods: TProcTypeModifiers; ptm: TProcTypeModifier; NewImplProcMods: TProcedureModifiers; pm: TProcedureModifier; @@ -9409,6 +9414,9 @@ begin if DeclArgs.Count<>ImplArgs.Count then RaiseNotYetImplemented(20190912110642,ImplProc); + DeclPTMods:=DeclProc.ProcType.Modifiers; + ImplPTMods:=ImplProc.ProcType.Modifiers; + DeclTemplates:=GetProcTemplateTypes(DeclProc); ImplTemplates:=GetProcTemplateTypes(ImplProc); if DeclTemplates<>nil then @@ -9465,33 +9473,36 @@ begin if CheckElTypeCompatibility(ImplResult,DeclResult,prraSimple)>cGenericExact then RaiseIncompatibleType(20170216151734,nResultTypeMismatchExpectedButFound, [],DeclResult,ImplResult,ImplProc); - - if ImplProc.IsAsync and not DeclProc.IsAsync then - RaiseMsg(20200524111856,nXModifierMismatchY,sXModifierMismatchY,['procedure type','async'],ImplProc); end; // calling convention if ImplProc.CallingConvention<>DeclProc.CallingConvention then RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc); - // proc modifiers - NewImplProcMods:=ImplProc.Modifiers-DeclProc.Modifiers-[pmAssembler]; - if not IsOverride then + // modifiers + if IsOverride then + begin + // override/class-intf-impl: calling conventions must match + NewImplPTMods:=ImplPTMods>[] then for pm in NewImplProcMods do RaiseMsg(20200518182445,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere, [ModifierNames[pm]],ImplProc.ProcType); + // implementation proc must not add modifiers + NewImplPTMods:=ImplPTMods-DeclPTMods; + if NewImplPTMods<>[] then + for ptm in NewImplPTMods do + RaiseMsg(20200425154821,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere, + [ProcTypeModifiers[ptm]],ImplProc.ProcType); end; - - // proc type modifiers - NewImplPTMods:=ImplProc.ProcType.Modifiers-DeclProc.ProcType.Modifiers; - // implementation proc must not add modifiers - if NewImplPTMods<>[] then - for ptm in NewImplPTMods do - RaiseMsg(20200425154821,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere, - [ProcTypeModifiers[ptm]],ImplProc.ProcType); end; procedure TPasResolver.ResolveImplBlock(Block: TPasImplBlock); diff --git a/compiler/packages/fcl-passrc/tests/tcresolvegenerics.pas b/compiler/packages/fcl-passrc/tests/tcresolvegenerics.pas index cf377b0..233db8e 100644 --- a/compiler/packages/fcl-passrc/tests/tcresolvegenerics.pas +++ b/compiler/packages/fcl-passrc/tests/tcresolvegenerics.pas @@ -3000,7 +3000,7 @@ begin 'procedure TBird.Run(a: TArray);', 'begin', ' a:=TArray(a);', - //' F:=TArray(a);', + ' F:=TArray(a);', 'end;', '']); ParseUnit; diff --git a/compiler/packages/pastojs/tests/tcmodules.pas b/compiler/packages/pastojs/tests/tcmodules.pas index d5d31e6..5fb832d 100644 --- a/compiler/packages/pastojs/tests/tcmodules.pas +++ b/compiler/packages/pastojs/tests/tcmodules.pas @@ -890,6 +890,7 @@ type Procedure TestAsync_ProcTypeAsyncModMismatchFail; Procedure TestAsync_Inherited; Procedure TestAsync_ClassInterface; + Procedure TestAsync_ClassInterface_AsyncMissmatchFail; end; function LinesToStr(Args: array of const): string; @@ -32942,8 +32943,18 @@ begin ' function _AddRef: longint;', ' function _Release: longint;', ' end;', + 'function Say(i: IUnknown): IUnknown; async;', + 'begin', + 'end;', 'function Run: IUnknown; async;', 'begin', + ' Result:=await(Run);', + ' Result:=await(Run());', + ' Result:=await(Run) as IUnknown;', + ' Result:=await(Say(nil));', + ' Result:=await(Say(await(Run())));', + ' Result:=await(Say(await(Run()) as IUnknown));', + ' Result:=await(Say(await(Run()) as IUnknown)) as IUnknown;', 'end;', 'procedure Fly;', 'var p: TJSPromise;', @@ -32959,8 +32970,25 @@ begin CheckSource('TestAsync_ClassInterface', LinesToStr([ // statements 'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);', + 'this.Say = async function (i) {', + ' var Result = null;', + ' return Result;', + '};', 'this.Run = async function () {', ' var Result = null;', + ' var $ok = false;', + ' try {', + ' Result = rtl.setIntfL(Result, await $mod.Run());', + ' Result = rtl.setIntfL(Result, await $mod.Run());', + ' Result = rtl.setIntfL(Result, rtl.intfAsIntfT(await $mod.Run(), $mod.IUnknown));', + ' Result = rtl.setIntfL(Result, await $mod.Say(null));', + ' Result = rtl.setIntfL(Result, await $mod.Say(await $mod.Run()));', + ' Result = rtl.setIntfL(Result, await $mod.Say(rtl.intfAsIntfT(await $mod.Run(), $mod.IUnknown)));', + ' Result = rtl.setIntfL(Result, rtl.intfAsIntfT(await $mod.Say(rtl.intfAsIntfT(await $mod.Run(), $mod.IUnknown)), $mod.IUnknown));', + ' $ok = true;', + ' } finally {', + ' if (!$ok) rtl._Release(Result);', + ' };', ' return Result;', '};', 'this.Fly = function () {', @@ -32976,6 +33004,29 @@ begin CheckResolverUnexpectedHints(); end; +procedure TTestModule.TestAsync_ClassInterface_AsyncMissmatchFail; +begin + StartProgram(true,[supTInterfacedObject]); + Add([ + '{$mode objfpc}', + '{$modeswitch externalclass}', + 'type', + ' TJSPromise = class external name ''Promise''', + ' end;', + ' IBird = interface', + ' procedure Run;', + ' end;', + ' TBird = class(TInterfacedObject,IBird)', + ' procedure Run; async;', + ' end;', + 'procedure TBird.Run;', + 'begin', + 'end;', + 'begin', + ' ']); + SetExpectedPasResolverError('procedure type modifier "async" mismatch',nXModifierMismatchY); + ConvertProgram; +end; Initialization RegisterTests([TTestModule]);