pas2js: built-in function await(const expr: T): T

git-svn-id: trunk@45442 -

packages/fcl-passrc/src/pasresolver.pp

@@ -2341,6 +2341,7 @@ type
     function ProcNeedsParams(El: TPasProcedureType): boolean;
     function IsProcOverride(AncestorProc, DescendantProc: TPasProcedure): boolean;
     function GetTopLvlProc(El: TPasElement): TPasProcedure;
+    function GetParentProc(El: TPasElement): TPasProcedure;
     function GetRangeLength(RangeExpr: TPasExpr): TMaxPrecInt;
     function EvalRangeLimit(RangeExpr: TPasExpr; Flags: TResEvalFlags;
       EvalLow: boolean; ErrorEl: TPasElement): TResEvalValue; virtual; // compute low() or high()
@@ -28440,6 +28441,17 @@ begin
     end;
 end;
 
+function TPasResolver.GetParentProc(El: TPasElement): TPasProcedure;
+begin
+  Result:=nil;
+  while El<>nil do
+    begin
+    if El is TPasProcedure then
+      exit(TPasProcedure(El));
+    El:=El.Parent;
+    end;
+end;
+
 function TPasResolver.GetRangeLength(RangeExpr: TPasExpr): TMaxPrecInt;
 var
   Range: TResEvalValue;

packages/fcl-passrc/src/pscanner.pp

@@ -666,8 +666,8 @@ type
     po_StopOnErrorDirective, // error on user $Error, $message error|fatal
     po_ExtConstWithoutExpr,  // allow typed const without expression in external class and with external modifier
     po_StopOnUnitInterface,  // parse only a unit name and stop at interface keyword
-    po_IgnoreUnknownResource, // Ignore resources for which no handler is registered.
-    po_AsyncProcs             // allow async procedure modifier
+    po_IgnoreUnknownResource,// Ignore resources for which no handler is registered.
+    po_AsyncProcs            // allow async procedure modifier
     );
   TPOptions = set of TPOption;
 

packages/pastojs/src/fppas2js.pp

@@ -404,6 +404,8 @@ Works:
 - overflow check:
   -Co   : Overflow checking of integer operations
 - generics
+- async procedure modifier
+- function await(const expr: T): T
 
 ToDos:
 - range check:
@@ -500,6 +502,7 @@ const
   nDuplicateMessageIdXAtY = 4029;
   nDispatchRequiresX = 4030;
   nConstRefNotForXAsConst = 4031;
+  nAWaitOnlyInAsyncProcedure = 3144;
 // resourcestring patterns of messages
 resourcestring
   sPasElementNotSupported = 'Pascal element not supported: %s';
@@ -533,6 +536,7 @@ resourcestring
   sDuplicateMessageIdXAtY = 'Duplicate message id "%s" at %s';
   sDispatchRequiresX = 'Dispatch requires %s';
   sConstRefNotForXAsConst = 'ConstRef not yet implemented for %s. Treating as Const';
+  sAWaitOnlyInAsyncProcedure = 'await only available in async procedure';
 
 const
   ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter
@@ -1416,6 +1420,12 @@ type
       Params: TParamsExpr; out ResolvedEl: TPasResolverResult); override;
     function BI_Debugger_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
       Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
+    function BI_AWait_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
+      Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
+    procedure BI_AWait_OnGetCallResult(Proc: TResElDataBuiltInProc;
+      Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
+    procedure BI_AWait_OnEval(Proc: TResElDataBuiltInProc;
+      Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
   public
     constructor Create; reintroduce;
     destructor Destroy; override;
@@ -2009,6 +2019,7 @@ type
     Function ConvertBuiltIn_Dispose(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_Default(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_Debugger(El: TPasExpr; AContext: TConvertContext): TJSElement; virtual;
+    Function ConvertBuiltIn_AWait(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertRecordValues(El: TRecordValues; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertSelfExpression(El: TSelfExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBinaryExpression(El: TBinaryExpr; AContext: TConvertContext): TJSElement; virtual;
@@ -5199,6 +5210,66 @@ begin
     Result:=cExact;
 end;
 
+function TPas2JSResolver.BI_AWait_OnGetCallCompatibility(
+  Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
+// function await(const Expr: T): T
+var
+  Params: TParamsExpr;
+  Param: TPasExpr;
+  ParamResolved: TPasResolverResult;
+  ParentProc: TPasProcedure;
+begin
+  Result:=cIncompatible;
+
+  // check if inside async proc
+  ParentProc:=GetParentProc(Expr);
+  if (ParentProc=nil) or not ParentProc.IsAsync then
+    begin
+    if RaiseOnError then
+      RaiseMsg(20200519153349,nAWaitOnlyInAsyncProcedure,sAWaitOnlyInAsyncProcedure,[],Expr);
+    exit;
+    end;
+
+  if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
+    exit;
+  Params:=TParamsExpr(Expr);
+  Param:=Params.Params[0];
+  ComputeElement(Param,ParamResolved,[]);
+  if not (rrfReadable in ParamResolved.Flags) then
+    exit(CheckRaiseTypeArgNo(20200519151816,1,Param,ParamResolved,'jsvalue',RaiseOnError));
+
+  Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
+  if Proc=nil then ;
+end;
+
+procedure TPas2JSResolver.BI_AWait_OnGetCallResult(Proc: TResElDataBuiltInProc;
+  Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
+// function await(const Expr: T): T
+var
+  Param: TPasExpr;
+begin
+  if length(Params.Params)<>1 then
+    RaiseMsg(20200519233144,nWrongNumberOfParametersForCallTo,
+      sWrongNumberOfParametersForCallTo,[Proc.Signature],Params);
+  Param:=Params.Params[0];
+  ComputeElement(Param,ResolvedEl,[]);
+end;
+
+procedure TPas2JSResolver.BI_AWait_OnEval(Proc: TResElDataBuiltInProc;
+  Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
+var
+  Param: TPasExpr;
+  ParamResolved: TPasResolverResult;
+begin
+  Evaluated:=nil;
+  if length(Params.Params)<>1 then
+    RaiseMsg(20200519233220,nWrongNumberOfParametersForCallTo,
+      sWrongNumberOfParametersForCallTo,[Proc.Signature],Params);
+  Param:=Params.Params[0];
+  ComputeElement(Param,ParamResolved,[]);
+  Evaluated:=Eval(Param,Flags);
+end;
+
 constructor TPas2JSResolver.Create;
 var
   bt: TPas2jsBaseType;
@@ -5292,6 +5363,12 @@ begin
   AddBuiltInProc('Debugger','procedure Debugger',
       @BI_Debugger_OnGetCallCompatibility,nil,
       nil,nil,bfCustom,[bipfCanBeStatement]);
+  // ToDo: AddBuiltInProc('Await','function await(T; const Expr: TJSPromise): T',
+  //    @BI_Await_OnGetCallCompatibility,@BI_Await_OnGetCallResult,
+  //    nil,nil,bfCustom,[bipfCanBeStatement]);
+  AddBuiltInProc('AWait','function await(const Expr: T): T',
+      @BI_AWait_OnGetCallCompatibility,@BI_AWait_OnGetCallResult,
+      @BI_AWait_OnEval,nil,bfCustom,[bipfCanBeStatement]);
 end;
 
 function TPas2JSResolver.CheckTypeCastRes(const FromResolved,
@@ -10288,6 +10365,7 @@ begin
           bfCustom:
             case BuiltInProc.Element.Name of
             'Debugger': Result:=ConvertBuiltIn_Debugger(El,AContext);
+            'AWait': Result:=ConvertBuiltIn_AWait(El,AContext);
             else
               RaiseNotSupported(El,AContext,20181126101801,'built in custom proc '+BuiltInProc.Element.Name);
             end;
@@ -13132,6 +13210,22 @@ begin
   if AContext=nil then ;
 end;
 
+function TPasToJSConverter.ConvertBuiltIn_AWait(El: TParamsExpr;
+  AContext: TConvertContext): TJSElement;
+var
+  Param: TPasExpr;
+  JS: TJSElement;
+  AWaitJS: TJSAwaitExpression;
+begin
+  if length(El.Params)<>1 then
+    RaiseNotSupported(El,AContext,20200519233919);
+  Param:=El.Params[0];
+  JS:=ConvertExpression(Param,AContext);
+  AWaitJS:=TJSAwaitExpression(CreateElement(TJSAwaitExpression,El));
+  AWaitJS.A:=JS;
+  Result:=AWaitJS;
+end;
+
 function TPasToJSConverter.ConvertRecordValues(El: TRecordValues;
   AContext: TConvertContext): TJSElement;
 var

packages/pastojs/tests/tcmodules.pas

@@ -341,6 +341,8 @@ type
     Procedure TestProc_ReservedWords;
     Procedure TestProc_ConstRefWord;
     Procedure TestProc_Async;
+    Procedure TestProc_AWaitOutsideAsyncFail;
+    Procedure TestProc_AWait;
 
     // anonymous functions
     Procedure TestAnonymousProc_Assign_ObjFPC;
@@ -4632,6 +4634,58 @@ begin
     ]));
 end;
 
+procedure TTestModule.TestProc_AWaitOutsideAsyncFail;
+begin
+  StartProgram(false);
+  Add([
+  'function Crawl(w: double): word; ',
+  'begin',
+  'end;',
+  'function Run(w: double): word;',
+  'begin',
+  '  Result:=await(Crawl(w));',
+  'end;',
+  'begin',
+  '  Run(1);']);
+  SetExpectedPasResolverError(sAWaitOnlyInAsyncProcedure,nAWaitOnlyInAsyncProcedure);
+  ConvertProgram;
+end;
+
+procedure TTestModule.TestProc_AWait;
+begin
+  StartProgram(false);
+  Add([
+  'function Crawl(d: double = 1.3): word; ',
+  'begin',
+  'end;',
+  'function Run(d: double): word; async;',
+  'begin',
+  '  Result:=await(1);',
+  '  Result:=await(Crawl);',
+  '  Result:=await(Crawl(4.5));',
+  'end;',
+  'begin',
+  '  Run(1);']);
+  ConvertProgram;
+  CheckSource('TestProc_AWait',
+    LinesToStr([ // statements
+    'this.Crawl = function (d) {',
+    '  var Result = 0;',
+    '  return Result;',
+    '};',
+    'this.Run = async function (d) {',
+    '  var Result = 0;',
+    '  Result = await 1;',
+    '  Result = await $mod.Crawl(1.3);',
+    '  Result = await $mod.Crawl(4.5);',
+    '  return Result;',
+    '};',
+    '']),
+    LinesToStr([
+    '$mod.Run(1);'
+    ]));
+end;
+
 procedure TTestModule.TestAnonymousProc_Assign_ObjFPC;
 begin
   StartProgram(false);
@@ -5117,22 +5171,31 @@ begin
   Add([
   '{$mode objfpc}',
   'type',
-  '  TFunc = reference to function(x: word): word;',
+  '  TFunc = reference to function(x: double): word;',
+  'function Crawl(d: double = 1.3): word; ',
+  'begin',
+  'end;',
   'var Func: TFunc;',
   'begin',
-  '  Func:=function(c:word):word async begin',
+  '  Func:=function(c:double):word async begin',
+  '    Result:=await(Crawl(c));',
   '  end;',
-  '  Func:=function(c:word):word async assembler asm',
+  '  Func:=function(c:double):word async assembler asm',
   '  end;',
   '  ']);
   ConvertProgram;
   CheckSource('TestAnonymousProc_Async',
     LinesToStr([ // statements
+    'this.Crawl = function (d) {',
+    '  var Result = 0;',
+    '  return Result;',
+    '};',
     'this.Func = null;',
     '']),
     LinesToStr([
     '$mod.Func = async function (c) {',
     '  var Result = 0;',
+    '  Result = await $mod.Crawl(c);',
     '  return Result;',
     '};',
     '$mod.Func = async function (c) {',