pas2js: async function exit(promise)

git-svn-id: trunk@45523 -

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;

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

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

utils/pas2js/docs/translation.html

@@ -3071,7 +3071,9 @@ end.
     Notes:
     <ul>
       <li>The await function does only compile time checks, no runtime checks.</li>
-      <li></li>
+      <li>Inside an async function/procedure you can pass a <i>TJSPromise</i> to the <i>exit()</i> function. For example:<br>
+        <i>exit(aPromise);</i><br>
+        <i>exit(inherited);</i></li>
     </ul>
     </div>