diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 92f8f7f8c0..0838a3da22 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -2346,7 +2346,7 @@ type function ProcNeedsParams(El: TPasProcedureType): boolean; function IsProcOverride(AncestorProc, DescendantProc: TPasProcedure): boolean; function GetTopLvlProc(El: TPasElement): TPasProcedure; - function GetParentProc(El: TPasElement): TPasProcedure; + function GetParentProc(El: TPasElement; GetDeclProc: boolean): TPasProcedure; function GetRangeLength(RangeExpr: TPasExpr): TMaxPrecInt; function EvalRangeLimit(RangeExpr: TPasExpr; Flags: TResEvalFlags; EvalLow: boolean; ErrorEl: TPasElement): TResEvalValue; virtual; // compute low() or high() @@ -11542,6 +11542,7 @@ begin and ((C=TPrimitiveExpr) or (C=TNilExpr) or (C=TBoolConstExpr) + or (C=TInheritedExpr) or (C=TProcedureExpr)) or (C=TInlineSpecializeExpr) then // ok @@ -18522,7 +18523,7 @@ begin while (i>0) and (not (Scopes[i] is TPasProcedureScope)) do dec(i); if i>0 then begin - // first param is function result + // inside procedure: first param is function result ProcScope:=TPasProcedureScope(Scopes[i]); CtxProc:=TPasProcedure(ProcScope.Element); if not (CtxProc.ProcType is TPasFunctionType) then @@ -28563,13 +28564,25 @@ begin end; end; -function TPasResolver.GetParentProc(El: TPasElement): TPasProcedure; +function TPasResolver.GetParentProc(El: TPasElement; GetDeclProc: boolean + ): TPasProcedure; +var + ProcScope: TPasProcedureScope; begin Result:=nil; while El<>nil do begin if El is TPasProcedure then - exit(TPasProcedure(El)); + begin + Result:=TPasProcedure(El); + if GetDeclProc and (El.CustomData is TPasProcedureScope) then + begin + ProcScope:=TPasProcedureScope(El.CustomData); + if ProcScope.DeclarationProc<>nil then + Result:=ProcScope.DeclarationProc; + end; + exit; + end; El:=El.Parent; end; end; diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index fc1684f882..9bbe531bc6 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -1439,6 +1439,8 @@ type ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags; var LeftResolved, RightResolved: TPasResolverResult); override; // built-in functions + function BI_Exit_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; + Expr: TPasExpr; RaiseOnError: boolean): integer; override; function BI_Val_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; override; procedure BI_TypeInfo_OnGetCallResult(Proc: TResElDataBuiltInProc; @@ -5070,6 +5072,39 @@ begin RightResolved); end; +function TPas2JSResolver.BI_Exit_OnGetCallCompatibility( + Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; +var + Params: TParamsExpr; + CtxProc: TPasProcedure; + ParamResolved: TPasResolverResult; + Param: TPasExpr; +begin + if (Expr is TParamsExpr) and (length(TParamsExpr(Expr).Params)=1) then + begin + Params:=TParamsExpr(Expr); + + CtxProc:=GetParentProc(Expr,true); + if (CtxProc<>nil) and CtxProc.IsAsync then + begin + // inside async proc + Param:=Params.Params[0]; + ComputeElement(Param,ParamResolved,[]); + + if (rrfReadable in ParamResolved.Flags) + and (ParamResolved.BaseType=btContext) + and (ParamResolved.LoTypeEl is TPasClassType) + and IsExternalClass_Name(TPasClassType(ParamResolved.LoTypeEl),'Promise') then + begin + // "exit(aPromise)" inside async proc + exit(cCompatible); + end; + end; + end; + + Result:=inherited BI_Exit_OnGetCallCompatibility(Proc, Expr, RaiseOnError); +end; + function TPas2JSResolver.BI_Val_OnGetCallCompatibility( Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; var @@ -5326,7 +5361,7 @@ begin Result:=cIncompatible; // check if inside async proc - ParentProc:=GetParentProc(Expr); + ParentProc:=GetParentProc(Expr,true); if (ParentProc=nil) or not ParentProc.IsAsync then begin if RaiseOnError then diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 81d39fd80d..a5eb9b2c3a 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -872,8 +872,8 @@ type Procedure TestAWait_ExternalClassPromise; Procedure TestAsync_AnonymousProc; Procedure TestAsync_ProcType; - // ToDo: proc type, implict call, explicit call, await() - // ToDo: proc type assign async mismatch fail + Procedure TestAsync_ProcTypeAsyncModMismatchFail; + Procedure TestAsync_Inherited; // ToDo: inherited; // ToDo: inherited asyncproc; // ToDo: await(inherited asyncproc); @@ -32014,6 +32014,92 @@ begin ''])); end; +procedure TTestModule.TestAsync_ProcTypeAsyncModMismatchFail; +begin + StartProgram(false); + Add([ + '{$mode objfpc}', + 'type', + ' TRefFunc = reference to function(x: double = 1.3): word;', + 'function Crawl(d: double): word; async;', + 'begin', + 'end;', + 'var', + ' RefFunc: TRefFunc;', + 'begin', + ' RefFunc:=@Crawl;', + ' ']); + SetExpectedPasResolverError('procedure type modifier "async" mismatch',nXModifierMismatchY); + ConvertProgram; +end; + +procedure TTestModule.TestAsync_Inherited; +begin + StartProgram(false); + Add([ + '{$mode objfpc}', + '{$modeswitch externalclass}', + 'type', + ' TJSPromise = class external name ''Promise''', + ' end;', + ' TObject = class', + ' function Run(w: word = 3): word; async; virtual;', + ' end;', + ' TBird = class', + ' function Run(w: word = 3): word; async; override;', + ' end;', + 'function TObject.Run(w: word = 3): word; async;', + 'begin', + 'end;', + 'function TBird.Run(w: word = 3): word; async;', + 'var p: TJSPromise;', + 'begin', + ' p:=inherited;', + ' p:=inherited Run;', + ' p:=inherited Run();', + ' p:=inherited Run(4);', + ' exit(p);', + ' exit(inherited);', + ' exit(inherited Run);', + ' exit(inherited Run(5));', + ' exit(6);', + 'end;', + 'begin', + ' ']); + ConvertProgram; + CheckSource('TestAsync_Inherited', + LinesToStr([ // statements + 'rtl.createClass($mod, "TObject", null, function () {', + ' this.$init = function () {', + ' };', + ' this.$final = function () {', + ' };', + ' this.Run = async function (w) {', + ' var Result = 0;', + ' return Result;', + ' };', + '});', + 'rtl.createClass($mod, "TBird", $mod.TObject, function () {', + ' this.Run = async function (w) {', + ' var Result = 0;', + ' var p = null;', + ' p = $mod.TObject.Run.apply(this, arguments);', + ' p = $mod.TObject.Run.call(this, 3);', + ' p = $mod.TObject.Run.call(this, 3);', + ' p = $mod.TObject.Run.call(this, 4);', + ' return p;', + ' return $mod.TObject.Run.apply(this, arguments);', + ' return $mod.TObject.Run.call(this, 3);', + ' return $mod.TObject.Run.call(this, 5);', + ' return 6;', + ' return Result;', + ' };', + '});', + '']), + LinesToStr([ + ''])); +end; + Initialization RegisterTests([TTestModule]); diff --git a/utils/pas2js/docs/translation.html b/utils/pas2js/docs/translation.html index 51e49602a0..2c50e04b1f 100644 --- a/utils/pas2js/docs/translation.html +++ b/utils/pas2js/docs/translation.html @@ -3071,7 +3071,9 @@ end. Notes: