fcl-passrc: fixed in mode delphi pass a function without at-operator to a proc type arg, pastojs: using new override

packages/fcl-passrc/src/pasresolver.pp

@@ -2242,6 +2242,8 @@ type
       Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil); virtual;
     procedure ComputeResultElement(El: TPasResultElement; out ResolvedEl: TPasResolverResult;
       Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil); virtual;
+    function ComputeProcAsyncResult(El: TPasElement; var ResolvedEl: TPasResolverResult;
+      Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil): boolean; virtual; // for descendants to return the promise
     function Eval(Expr: TPasExpr; Flags: TResEvalFlags; Store: boolean = true): TResEvalValue; overload;
     function Eval(const Value: TPasResolverResult; Flags: TResEvalFlags; Store: boolean = true): TResEvalValue; overload;
     // checking compatibilility
@@ -14019,7 +14021,11 @@ begin
   else if IsProcedureType(ArgResolved,true)
       or (ArgResolved.BaseType=btPointer)
       or ((ArgResolved.LoTypeEl=nil) and (ArgResolved.IdentEl is TPasArgument)) then
+  begin
     Include(RHSFlags,rcNoImplicitProcType);
+    if msDelphi in GetElModeSwitches(Expr) then
+      Include(RHSFlags,rcNoImplicitProc);
+  end;
   if SetReferenceFlags then
     Include(RHSFlags,rcSetReferenceFlags);
   ComputeElement(Expr,ExprResolved,RHSFlags);
@@ -14241,11 +14247,8 @@ begin
         // function call => return result
         ComputeResultElement(TPasFunctionType(Proc.ProcType).ResultEl,ResolvedEl,
           Flags+[rcCall],StartEl)
-      else if Proc.IsAsync then
-        begin
+      else if Proc.IsAsync and ComputeProcAsyncResult(Proc,ResolvedEl,Flags,StartEl) then
         // async proc => return promise
-        ComputeElement(Proc,ResolvedEl,Flags+[rcCall],StartEl);
-        end
       else if (Proc.ClassType=TPasConstructor) then
         begin
         // constructor -> return value of type class
@@ -14272,6 +14275,10 @@ begin
           // function call => return result
           ComputeResultElement(TPasFunctionType(ResolvedEl.LoTypeEl).ResultEl,
             ResolvedEl,Flags+[rcCall],StartEl)
+        else if (ResolvedEl.LoTypeEl is TPasProcedureType)
+            and TPasProcedureType(ResolvedEl.LoTypeEl).IsAsync
+            and ComputeProcAsyncResult(ResolvedEl.LoTypeEl,ResolvedEl,Flags,StartEl) then
+          // async proc => return promise
         else
           // procedure call, result is neither readable nor writable
           SetResolverTypeExpr(ResolvedEl,btProc,
@@ -27842,11 +27849,9 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
               ResolvedEl,Flags+[rcCall],StartEl);
             end
           else if (ResolvedEl.IdentEl is TPasProcedure)
-              and TPasProcedure(ResolvedEl.IdentEl).IsAsync then
-            begin
+              and TPasProcedure(ResolvedEl.IdentEl).IsAsync
+              and ComputeProcAsyncResult(ResolvedEl.IdentEl,ResolvedEl,Flags,StartEl) then
             // async proc => return promise
-            ComputeElement(ResolvedEl.IdentEl,ResolvedEl,Flags+[rcCall],StartEl);
-            end
           else if (ResolvedEl.IdentEl.ClassType=TPasConstructor) then
             begin
             // constructor -> return value of type class
@@ -27885,6 +27890,10 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
             // function => return result
             ComputeResultElement(TPasFunctionType(ResolvedEl.LoTypeEl).ResultEl,
               ResolvedEl,Flags+[rcCall],StartEl)
+          else if (ResolvedEl.LoTypeEl is TPasProcedureType)
+              and TPasProcedureType(ResolvedEl.LoTypeEl).IsAsync
+              and ComputeProcAsyncResult(ResolvedEl.LoTypeEl,ResolvedEl,Flags,StartEl) then
+            // async proc => return promise
           else if ParentNeedsExprResult(Expr) then
             begin
             // a procedure has no result
@@ -28418,6 +28427,16 @@ begin
   ResolvedEl.Flags:=[rrfReadable,rrfWritable];
 end;
 
+function TPasResolver.ComputeProcAsyncResult(El: TPasElement; var ResolvedEl: TPasResolverResult;
+  Flags: TPasResolverComputeFlags; StartEl: TPasElement): boolean;
+begin
+  Result:=false;
+  if El=nil then ;
+  if Flags=[] then ;
+  if StartEl=nil then ;
+  if ResolvedEl.IdentEl=nil then ;
+end;
+
 function TPasResolver.Eval(Expr: TPasExpr; Flags: TResEvalFlags;
   Store: boolean): TResEvalValue;
 // Important: Caller must free result with ReleaseEvalValue(Result)

packages/fcl-passrc/tests/tcresolver.pas

@@ -902,6 +902,8 @@ type
     Procedure TestProcType_TNotifyEvent_NoAtFPC_Fail1;
     Procedure TestProcType_TNotifyEvent_NoAtFPC_Fail2;
     Procedure TestProcType_TNotifyEvent_NoAtFPC_Fail3;
+    Procedure TestProcType_PassAsArg_NoAtFPC_Fail;
+    Procedure TestProcType_PassAsArg_NoAtDelphi;
     Procedure TestProcType_WhileListCompare;
     Procedure TestProcType_IsNested;
     Procedure TestProcType_IsNested_AssignProcFail;
@@ -1372,7 +1374,7 @@ var
 
   procedure AddLabel;
   var
-    Identifier, Param: String;
+    Identifier: String;
     p: PChar;
   begin
     p:=CommentStartP+2;
@@ -16635,6 +16637,38 @@ begin
     nWrongNumberOfParametersForCallTo);
 end;
 
+procedure TTestResolver.TestProcType_PassAsArg_NoAtFPC_Fail;
+begin
+  StartProgram(false);
+  Add('{$mode objfpc}');
+  Add('type');
+  Add('  TProc = procedure;');
+  Add('procedure Run;');
+  Add('begin end;');
+  Add('procedure Fly(p: TProc);');
+  Add('begin end;');
+  Add('begin');
+  Add('  Fly(Run);');
+  CheckResolverException(
+    'Incompatible type for arg no. 1: Got "procedural type", expected "TProc"',
+    nIncompatibleTypeArgNo);
+end;
+
+procedure TTestResolver.TestProcType_PassAsArg_NoAtDelphi;
+begin
+  StartProgram(false);
+  Add('{$mode delphi}');
+  Add('type');
+  Add('  TFunc = function: word;');
+  Add('function Run: word;');
+  Add('begin end;');
+  Add('procedure Fly(p: TFunc);');
+  Add('begin end;');
+  Add('begin');
+  Add('  Fly(Run);');
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestProcType_WhileListCompare;
 begin
   StartProgram(false);

packages/pastojs/src/fppas2js.pp

@@ -1696,11 +1696,11 @@ type
     procedure CheckDispatchField(Proc: TPasProcedure; Switch: TValueSwitch);
     procedure AddMessageStr(var MsgToProc: TMessageIdToProc_List; const S: string; Proc: TPasProcedure);
     procedure AddMessageIdToClassScope(Proc: TPasProcedure; EmitHints: boolean); virtual;
-    procedure ComputeElement(El: TPasElement; out ResolvedEl: TPasResolverResult;
-      Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil); override;
     procedure ComputeResultElement(El: TPasResultElement; out
       ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
       StartEl: TPasElement = nil); override;
+    function ComputeProcAsyncResult(El: TPasElement; var ResolvedEl: TPasResolverResult;
+      Flags: TPasResolverComputeFlags; StartEl: TPasElement=nil): boolean; override;
     // CustomData
     function GetElementData(El: TPasElementBase;
       DataClass: TPas2JsElementDataClass): TPas2JsElementData; virtual;
@@ -7320,52 +7320,53 @@ begin
   end;
 end;
 
-procedure TPas2JSResolver.ComputeElement(El: TPasElement; out
+procedure TPas2JSResolver.ComputeResultElement(El: TPasResultElement; out
   ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
   StartEl: TPasElement);
 var
   Proc: TPasProcedure;
+  ProcType: TPasProcedureType;
   JSPromiseClass: TPasClassType;
 begin
-  if (rcCall in Flags) and (El is TPasProcedure) then
+  if (rcCall in Flags) and (El.Parent is TPasProcedureType) then
     begin
-    Proc:=TPasProcedure(El);
-    if Proc.IsAsync then
+    ProcType:=TPasProcedureType(El.Parent);
+    if ProcType.Parent is TPasProcedure then
       begin
-      // an async function call returns a TJSPromise if available
-      JSPromiseClass:=FindTJSPromise(nil);
-      if JSPromiseClass<>nil then
+      Proc:=TPasProcedure(ProcType.Parent);
+      if Proc.IsAsync then
         begin
-         SetResolverIdentifier(ResolvedEl, btContext, El, JSPromiseClass,
-           JSPromiseClass, [rrfReadable, rrfWritable]);
-         Exit;
+        // an async function returns a TJSPromise if available
+        JSPromiseClass:=FindTJSPromise(nil); // nil for no error on fail
+        if JSPromiseClass<>nil then
+          begin
+           SetResolverIdentifier(ResolvedEl, btContext, El, JSPromiseClass,
+             JSPromiseClass, [rrfReadable, rrfWritable]);
+           Exit;
+          end;
         end;
       end;
     end;
-  inherited ComputeElement(El,ResolvedEl,Flags,StartEl);
+  inherited ComputeResultElement(El, ResolvedEl, Flags, StartEl);
 end;
 
-procedure TPas2JSResolver.ComputeResultElement(El: TPasResultElement; out
-  ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
-  StartEl: TPasElement);
+function TPas2JSResolver.ComputeProcAsyncResult(El: TPasElement;
+  var ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags; StartEl: TPasElement
+  ): boolean;
 var
-  FuncType: TPasFunctionType;
-  Proc: TPasProcedure;
+  JSPromiseClass: TPasClassType;
 begin
-  if (rcCall in Flags) and (El.Parent is TPasFunctionType) then
+  JSPromiseClass:=FindTJSPromise(nil); // nil for no error on fail
+  if JSPromiseClass=nil then
+    exit(false)
+  else
     begin
-    FuncType:=TPasFunctionType(El.Parent);
-    if FuncType.Parent is TPasProcedure then
-      begin
-      Proc:=TPasProcedure(FuncType.Parent);
-      if Proc.IsAsync then
-        begin
-        ComputeElement(Proc, ResolvedEl, Flags, StartEl);
-        Exit;
-        end;
-      end;
+    SetResolverIdentifier(ResolvedEl, btContext, El, JSPromiseClass,
+      JSPromiseClass, [rrfReadable, rrfWritable]);
+    exit(true);
     end;
-  inherited ComputeResultElement(El, ResolvedEl, Flags, StartEl);
+  if StartEl=nil then ;
+  if Flags=[] then ;
 end;
 
 function TPas2JSResolver.GetElementData(El: TPasElementBase;

packages/pastojs/tests/tcmodules.pas

@@ -944,22 +944,22 @@ type
     Procedure TestAttributes_InterfacesList;
 
     // Assertions, checks
-    procedure TestAssert;
-    procedure TestAssert_SysUtils;
-    procedure TestObjectChecks;
-    procedure TestOverflowChecks_Int;
-    procedure TestRangeChecks_AssignInt;
-    procedure TestRangeChecks_AssignIntRange;
-    procedure TestRangeChecks_AssignEnum;
-    procedure TestRangeChecks_AssignEnumRange;
-    procedure TestRangeChecks_AssignChar;
-    procedure TestRangeChecks_AssignCharRange;
-    procedure TestRangeChecks_ArrayIndex;
-    procedure TestRangeChecks_ArrayOfRecIndex;
-    procedure TestRangeChecks_StringIndex;
-    procedure TestRangeChecks_TypecastInt;
-    procedure TestRangeChecks_TypeHelperInt;
-    procedure TestRangeChecks_AssignCurrency;
+    Procedure TestAssert;
+    Procedure TestAssert_SysUtils;
+    Procedure TestObjectChecks;
+    Procedure TestOverflowChecks_Int;
+    Procedure TestRangeChecks_AssignInt;
+    Procedure TestRangeChecks_AssignIntRange;
+    Procedure TestRangeChecks_AssignEnum;
+    Procedure TestRangeChecks_AssignEnumRange;
+    Procedure TestRangeChecks_AssignChar;
+    Procedure TestRangeChecks_AssignCharRange;
+    Procedure TestRangeChecks_ArrayIndex;
+    Procedure TestRangeChecks_ArrayOfRecIndex;
+    Procedure TestRangeChecks_StringIndex;
+    Procedure TestRangeChecks_TypecastInt;
+    Procedure TestRangeChecks_TypeHelperInt;
+    Procedure TestRangeChecks_AssignCurrency;
 
     // Async/AWait
     Procedure TestAsync_Proc;
@@ -979,6 +979,8 @@ type
     Procedure TestAsync_AnonymousProc_PromiseViaDotContext;
     Procedure TestAsync_ProcType;
     Procedure TestAsync_ProcTypeAsyncModMismatchFail;
+    Procedure TestAsync_ProcTypeDelphi_NoTJSPromise;
+    Procedure TestAsync_ProcTypeDelphi_TJSPromise;
     Procedure TestAsync_Inherited;
     Procedure TestAsync_ClassInterface;
     Procedure TestAsync_ClassInterface_AsyncMissmatchFail;
@@ -36587,6 +36589,47 @@ begin
   ConvertProgram;
 end;
 
+procedure TTestModule.TestAsync_ProcTypeDelphi_NoTJSPromise;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TRefProc = reference to procedure; async;',
+  'procedure Run(p: TRefProc);',
+  'begin',
+  'end;',
+  'procedure Fly; async;',
+  'begin',
+  'end;',
+  'begin',
+  '  Run(Fly);',
+  '  ']);
+  ConvertProgram;
+end;
+
+procedure TTestModule.TestAsync_ProcTypeDelphi_TJSPromise;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  '{$modeswitch externalclass}',
+  'type',
+  '  TJSPromise = class external name ''Promise''',
+  '  end;',
+  '  TRefProc = reference to procedure; async;',
+  'procedure Run(p: TRefProc);',
+  'begin',
+  'end;',
+  'procedure Fly; async;',
+  'begin',
+  'end;',
+  'begin',
+  '  Run(Fly);',
+  '  ']);
+  ConvertProgram;
+end;
+
 procedure TTestModule.TestAsync_Inherited;
 begin
   StartProgram(false);