fcl-passrc: typecast anonymous proc to proctype

git-svn-id: trunk@40516 -

packages/fcl-passrc/src/pasresolver.pp

@@ -214,11 +214,11 @@ Works:
   - assign in proc and program begin and initialization   p:=procedure begin end
   - pass as arg  doit(procedure begin end)
   - modifiers  assembler varargs cdecl
+  - typecast
 
 ToDo:
 - anonymous methods:
   - with
-  - typecast
   - self
 - Include/Exclude for set of int/char/bool
 - set of CharRange
@@ -1853,6 +1853,7 @@ type
     function IsEmptyArrayExpr(const ResolvedEl: TPasResolverResult): boolean;
     function IsClassMethod(El: TPasElement): boolean;
     function IsClassField(El: TPasElement): boolean;
+    function IsMethod(El: TPasProcedure): boolean;
     function IsExternalClass_Name(aClass: TPasClassType; const ExtName: string): boolean;
     function IsProcedureType(const ResolvedEl: TPasResolverResult; HasValue: boolean): boolean;
     function IsArrayType(const ResolvedEl: TPasResolverResult): boolean;
@@ -19276,6 +19277,41 @@ begin
           else
             Result:=cCompatible;
           end
+        end
+      else if FromResolved.BaseType=btProc then
+        begin
+        FromTypeEl:=FromResolved.LoTypeEl;
+        if FromTypeEl is TPasProcedureType then
+          begin
+          // typecast procedure (or anonymous procedure) to proctype
+          FromProcType:=TPasProcedureType(FromTypeEl);
+          if (msDelphi in CurrentParser.CurrentModeswitches)
+              and (FromResolved.IdentEl=nil) then
+            // Delphi forbids typecast procedure to proctype
+          else if ToProcType.IsReferenceTo then
+            Result:=cCompatible
+          else if FromResolved.IdentEl=nil then
+            // anonymous proc to proctype
+            Result:=cCompatible
+          else if (FromProcType.IsOfObject<>ToProcType.IsOfObject)
+              and not (proMethodAddrAsPointer in Options) then
+            begin
+            // e.g. TProcedure(Obj.DoIt)
+            if RaiseOnError then
+              RaiseMsg(20181210151058,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
+                [GetElementTypeName(FromProcType)+BoolToStr(FromProcType.IsOfObject,' '+ProcTypeModifiers[ptmOfObject],''),
+                 ToProcType.ElementTypeName+BoolToStr(ToProcType.IsOfObject,' '+ProcTypeModifiers[ptmOfObject],'')],ErrorEl);
+            end
+          else if FromProcType.IsNested<>ToProcType.IsNested then
+            begin
+            if RaiseOnError then
+              RaiseMsg(20181210151102,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
+                [GetElementTypeName(FromProcType)+BoolToStr(FromProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],''),
+                 ToProcType.ElementTypeName+BoolToStr(ToProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],'')],ErrorEl);
+            end
+          else
+            Result:=cCompatible;
+          end;
         end;
       end
     else if C=TPasPointerType then
@@ -20298,6 +20334,18 @@ begin
     and (El.Parent is TPasClassType);
 end;
 
+function TPasResolver.IsMethod(El: TPasProcedure): boolean;
+var
+  ProcScope: TPasProcedureScope;
+begin
+  Result:=false;
+  if El=nil then exit;
+  if El.Parent is TPasClassType then exit(true);
+  if not (El.CustomData is TPasProcedureScope) then exit;
+  ProcScope:=TPasProcedureScope(El.CustomData);
+  Result:=IsMethod(ProcScope.DeclarationProc);
+end;
+
 function TPasResolver.IsExternalClass_Name(aClass: TPasClassType;
   const ExtName: string): boolean;
 var

packages/fcl-passrc/tests/tcresolver.pas

@@ -459,11 +459,13 @@ type
     Procedure TestAnonymousProc_StatementFail;
     // ToDo: Delphi does not support calling directly: function(i: word):word begin end(3)
     // ToDo: Delphi does support calling with typecast: TFunc(function(i: word):word begin end)(3)
-    Procedure TestAnonymousProc_Typecast;// ToDo
+    Procedure TestAnonymousProc_Typecast;
+    Procedure TestAnonymousProc_TypecastToResultFail;
+    Procedure TestAnonymousProc_With; // ToDo
     // ToDo: ano in with (ano proc can access with scope)
+    // ToDo: ano in except E: Exception do ..
     // ToDo: ano in nested
     // ToDo: ano in ano
-    // ToDo: ano in except E: Exception do ..
     // ToDo: fppas2js: check "is TPasFunction", ".FuncType", "is TPasProcedureBody"
 
     // record
@@ -7312,16 +7314,55 @@ end;
 
 procedure TTestResolver.TestAnonymousProc_Typecast;
 begin
-  exit;
-
   StartProgram(false);
   Add([
   'type',
   '  TProc = reference to procedure(w: word);',
   'procedure DoIt(p: TProc);',
   'begin',
-  '  p:=TProc(procedure(b: byte) begin end);',
-  '  p:=TProc(procedure(b: byte) begin end;);',
+  '  p:=TProc(procedure(b: smallint) begin end);',
+  'end;',
+  'begin']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestAnonymousProc_TypecastToResultFail;
+begin
+  StartProgram(false);
+  Add([
+  'procedure DoIt;',
+  'var i: longint;',
+  'begin',
+  '  i:=longint(function(b: byte): byte begin end);',
+  'end;',
+  'begin']);
+  CheckResolverException('Illegal type conversion: "Procedure/Function" to "Longint"',
+    nIllegalTypeConversionTo);
+end;
+
+procedure TTestResolver.TestAnonymousProc_With;
+begin
+  exit;
+
+  StartProgram(false);
+  Add([
+  'type',
+  '  TProc = reference to procedure(w: word);',
+  '  TObject = class end;',
+  '  TBird = class',
+  '    {#b_bool}b: boolean;',
+  '  end;',
+  'procedure DoIt({#i}i: longint);',
+  'var',
+  '  {#p}p: TProc;',
+  '  {#b_bird}bi: TBird;',
+  'begin',
+  '  with {@b_bird}bi do begin',
+  '    {@p}p:=procedure({#w}w: word)',
+  '      begin',
+  '        {@b_bool}b:=true;',
+ // '        {@b_bool}b:=({@w}w+{@i}i)>2;',
+  '      end; end;',
   'end;',
   'begin']);
   ParseProgram;