fcl-passrc: anonymous procedure type

packages/fcl-passrc/src/pasresolver.pp

@@ -1665,6 +1665,7 @@ type
     procedure AccessExpr(Expr: TPasExpr; Access: TResolvedRefAccess);
     function MarkArrayExpr(Expr: TParamsExpr; ArrayType: TPasArrayType): boolean; virtual;
     procedure MarkArrayExprRecursive(Expr: TPasExpr; ArrType: TPasArrayType); virtual;
+    procedure DeanonymizeType(El: TPasType); virtual;
     procedure FinishModule(CurModule: TPasModule); virtual;
     procedure FinishUsesClause; virtual;
     procedure FinishSection(Section: TPasSection); virtual;
@@ -6303,82 +6304,15 @@ begin
 end;
 
 procedure TPasResolver.FinishSubElementType(Parent: TPasElement; El: TPasType);
-
-  procedure InsertInFront(NewParent: TPasElement; List: TFPList
-    {$IFDEF CheckPasTreeRefCount};const aId: string{$ENDIF});
-  var
-    i: Integer;
-    p, Prev: TPasElement;
-  begin
-    p:=El.Parent;
-    if NewParent=p.Parent then
-      begin
-      // e.g. m,n:array of longint; -> insert n$a in front of m
-      i:=List.Count-1;
-      while (i>=0) and (List[i]<>Pointer(p)) do
-        dec(i);
-      if P is TPasVariable then
-        begin
-        while (i>0) do
-          begin
-          Prev:=TPasElement(List[i-1]);
-          if (Prev.ClassType=P.ClassType) and (TPasVariable(Prev).VarType=TPasVariable(P).VarType) then
-            dec(i) // e.g. m,n: array of longint
-          else
-            break;
-          end;
-        end;
-      if i<0 then
-        List.Add(El)
-      else
-        List.Insert(i,El);
-      end
-    else
-      begin
-      List.Add(El);
-      end;
-    El.AddRef{$IFDEF CheckPasTreeRefCount}(aID){$ENDIF};
-    El.Parent:=NewParent;
-  end;
-
 var
-  Decl: TPasDeclarations;
   EnumScope: TPasEnumTypeScope;
-  p: TPasElement;
-  MembersType: TPasMembersType;
 begin
   EmitTypeHints(Parent,El);
   if (El.Name<>'') or (AnonymousElTypePostfix='') then exit;
-  if Parent.Name='' then
-    RaiseMsg(20170415165455,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
   if El.Parent<>Parent then
-    RaiseNotYetImplemented(20190215085011,Parent);
-  // give anonymous sub type a name
-  El.Name:=Parent.Name+AnonymousElTypePostfix;
-  {$IFDEF VerbosePasResolver}
-  writeln('TPasResolver.FinishSubElementType parent="',GetObjName(Parent),'" named anonymous type "',GetObjName(El),'"');
-  {$ENDIF}
+    RaiseNotYetImplemented(20220320123426,Parent,GetElementTypeName(El));
+  DeanonymizeType(El);
 
-  p:=Parent.Parent;
-  repeat
-    if p is TPasDeclarations then
-      begin
-      Decl:=TPasDeclarations(p);
-      InsertInFront(Decl,Decl.Declarations{$IFDEF CheckPasTreeRefCount},'TPasDeclarations.Declarations'{$ENDIF});
-      Decl.Types.Add(El);
-      break;
-      end
-    else if p is TPasMembersType then
-      begin
-      MembersType:=TPasMembersType(p);
-      InsertInFront(MembersType,MembersType.Members{$IFDEF CheckPasTreeRefCount},'TPasMembersType.Members'{$ENDIF});
-      break;
-      end
-    else
-      p:=p.Parent;
-    if p=nil then
-      RaiseMsg(20170416094735,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
-  until false;
   if (El.ClassType=TPasEnumType) and (Parent.ClassType=TPasSetType) then
     begin
     // anonymous enumtype
@@ -7408,9 +7342,7 @@ begin
   else if El.Name<>'' then
     begin
     // finished proc type, e.g. type TProcedure = procedure;
-    end
-  else
-    RaiseNotYetImplemented(20160922163411,El.Parent,'anonymous procedure type');
+    end;
 end;
 
 procedure TPasResolver.FinishMethodDeclHeader(Proc: TPasProcedure);
@@ -12097,6 +12029,91 @@ begin
   Traverse(Expr,ArrType,0);
 end;
 
+procedure TPasResolver.DeanonymizeType(El: TPasType);
+
+  procedure InsertInFront(NewParent: TPasElement; List: TFPList
+    {$IFDEF CheckPasTreeRefCount};const aId: string{$ENDIF});
+  var
+    i: Integer;
+    p, Prev: TPasElement;
+  begin
+    p:=El.Parent;
+    if NewParent=p.Parent then
+      begin
+      // e.g. m,n:array of longint; -> insert n$a in front of m
+      i:=List.Count-1;
+      while (i>=0) and (List[i]<>Pointer(p)) do
+        dec(i);
+      if P is TPasVariable then
+        begin
+        while (i>0) do
+          begin
+          Prev:=TPasElement(List[i-1]);
+          if (Prev.ClassType=P.ClassType) and (TPasVariable(Prev).VarType=TPasVariable(P).VarType) then
+            dec(i) // e.g. m,n: array of longint
+          else
+            break;
+          end;
+        end;
+      if i<0 then
+        List.Add(El)
+      else
+        List.Insert(i,El);
+      end
+    else
+      begin
+      List.Add(El);
+      end;
+    El.AddRef{$IFDEF CheckPasTreeRefCount}(aID){$ENDIF};
+    El.Parent:=NewParent;
+  end;
+
+var
+  Decl: TPasDeclarations;
+  p: TPasElement;
+  MembersType: TPasMembersType;
+  CurName: String;
+begin
+  if (AnonymousElTypePostfix='') then
+    exit;
+  if (El.Name<>'') then
+    RaiseNotYetImplemented(20220320121923,El);
+
+  CurName:='';
+  p:=El.Parent;
+  repeat
+    if (p is TPasDeclarations) or (p is TPasMembersType) then
+      begin
+      if CurName='' then
+        RaiseMsg(20220320122946,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
+      El.Name:=CurName+AnonymousElTypePostfix;
+      {$IFDEF VerbosePasResolver}
+      writeln('TPasResolver.DeanonymizeType named anonymous type "',GetObjPath(El),'"');
+      {$ENDIF}
+      if p is TPasDeclarations then
+        begin
+        Decl:=TPasDeclarations(p);
+        InsertInFront(Decl,Decl.Declarations{$IFDEF CheckPasTreeRefCount},'TPasDeclarations.Declarations'{$ENDIF});
+        Decl.Types.Add(El);
+        end
+      else if p is TPasMembersType then
+        begin
+        MembersType:=TPasMembersType(p);
+        InsertInFront(MembersType,MembersType.Members{$IFDEF CheckPasTreeRefCount},'TPasMembersType.Members'{$ENDIF});
+        end;
+      break;
+      end
+    else if p.Name<>'' then
+      begin
+      if CurName<>'' then
+        CurName:=p.Name+'__'+CurName
+      else
+        CurName:=p.Name;
+      end;
+    p:=p.Parent;
+  until false;
+end;
+
 procedure TPasResolver.CheckPointerCycle(El: TPasPointerType);
 var
   C: TClass;
@@ -12547,7 +12564,8 @@ procedure TPasResolver.AddProcedureType(El: TPasProcedureType;
 var
   Scope: TPasProcTypeScope;
 begin
-  if El.Name<>'' then begin
+  if El.Name<>'' then
+    begin
     {$IFDEF VerbosePasResolver}
     writeln('TPasResolver.AddProcedureType ',GetObjName(El),' Parent=',GetObjName(El.Parent));
     {$ENDIF}
@@ -12571,8 +12589,24 @@ begin
       Scope:=TPasProcTypeScope(PushScope(El,ScopeClass_ProcType));
       AddGenericTemplateIdentifiers(TypeParams,Scope);
       end;
-  end else if TypeParams<>nil then
-    RaiseNotYetImplemented(20190813193745,El);
+    end
+  else
+    begin
+    // no name
+    if TypeParams<>nil then
+      RaiseNotYetImplemented(20190813193745,El);
+    if El.Parent=nil then
+      RaiseNotYetImplemented(20220320122040,El);
+    if El.Parent is TPasProcedure then
+      // proctype of procedure has no name -> normal
+    else
+      begin
+      // anonymous procedure type, e.g. "var p: procedure;"
+      writeln('AAA1 TPasResolver.AddProcedureType ',GetObjPath(El));
+      DeanonymizeType(El);
+      writeln('AAA2 TPasResolver.AddProcedureType ',GetObjPath(El));
+      end;
+    end;
 end;
 
 procedure TPasResolver.AddProcedure(El: TPasProcedure; TypeParams: TFPList);

packages/fcl-passrc/src/pparser.pp

@@ -1163,7 +1163,7 @@ begin
 
   TPasFunctionType(Result).ResultEl :=
     TPasResultElement(CreateElement(TPasResultElement, AResultName, ResultParent,
-    visDefault, ASrcPos, TypeParams));
+                                    visDefault, ASrcPos, TypeParams));
 end;
 
 function TPasTreeContainer.FindElementFor(const AName: String;

packages/fcl-passrc/tests/tcresolver.pas

@@ -890,6 +890,9 @@ type
     Procedure TestProcType_InsideFunction;
     Procedure TestProcType_PassProcToUntyped;
 
+    // anonymous procedure type
+    Procedure TestProcTypeAnonymous_FunctionFunctionFail; // ToDo
+
     // pointer
     Procedure TestPointer;
     Procedure TestPointer_AnonymousSetFail;
@@ -15542,63 +15545,64 @@ end;
 procedure TTestResolver.TestProcTypesAssignObjFPC;
 begin
   StartProgram(false);
-  Add('type');
-  Add('  TProcedure = procedure;');
-  Add('  TFunctionInt = function:longint;');
-  Add('  TFunctionIntFunc = function:TFunctionInt;');
-  Add('  TFunctionIntFuncFunc = function:TFunctionIntFunc;');
-  Add('function GetNumber: longint;');
-  Add('begin');
-  Add('  Result:=3;');
-  Add('end;');
-  Add('function GetNumberFunc: TFunctionInt;');
-  Add('begin');
-  Add('  Result:=@GetNumber;');
-  Add('end;');
-  Add('function GetNumberFuncFunc: TFunctionIntFunc;');
-  Add('begin');
-  Add('  Result:=@GetNumberFunc;');
-  Add('end;');
-  Add('var');
-  Add('  i: longint;');
-  Add('  f: TFunctionInt;');
-  Add('  ff: TFunctionIntFunc;');
-  Add('begin');
-  Add('  i:=GetNumber; // omit ()');
-  Add('  i:=GetNumber();');
-  Add('  i:=GetNumberFunc()();');
-  Add('  i:=GetNumberFuncFunc()()();');
-  Add('  if i=GetNumberFunc()() then ;');
-  Add('  if GetNumberFunc()()=i then ;');
-  Add('  if i=GetNumberFuncFunc()()() then ;');
-  Add('  if GetNumberFuncFunc()()()=i then ;');
-  Add('  f:=nil;');
-  Add('  if f=nil then ;');
-  Add('  if nil=f then ;');
-  Add('  if Assigned(f) then ;');
-  Add('  f:=f;');
-  Add('  f:=@GetNumber;');
-  Add('  f:=GetNumberFunc; // not in Delphi');
-  Add('  f:=GetNumberFunc(); // not in Delphi');
-  Add('  f:=GetNumberFuncFunc()();');
-  Add('  if f=f then ;');
-  Add('  if i=f then ;');
-  Add('  if i=f() then ;');
-  Add('  if f()=i then ;');
-  Add('  if f()=f() then ;');
-  Add('  if f=@GetNumber then ;');
-  Add('  if @GetNumber=f then ;');
-  Add('  if f=GetNumberFunc then ;');
-  Add('  if f=GetNumberFunc() then ;');
-  Add('  if f=GetNumberFuncFunc()() then ;');
-  Add('  ff:=nil;');
-  Add('  if ff=nil then ;');
-  Add('  if nil=ff then ;');
-  Add('  ff:=ff;');
-  Add('  if ff=ff then ;');
-  Add('  ff:=@GetNumberFunc;');
-  Add('  ff:=GetNumberFuncFunc; // not in Delphi');
-  Add('  ff:=GetNumberFuncFunc();');
+  Add([
+  'type',
+  '  TProcedure = procedure;',
+  '  TFunctionInt = function:longint;',
+  '  TFunctionIntFunc = function:TFunctionInt;',
+  '  TFunctionIntFuncFunc = function:TFunctionIntFunc;',
+  'function GetNumber: longint;',
+  'begin',
+  '  Result:=3;',
+  'end;',
+  'function GetNumberFunc: TFunctionInt;',
+  'begin',
+  '  Result:=@GetNumber;',
+  'end;',
+  'function GetNumberFuncFunc: TFunctionIntFunc;',
+  'begin',
+  '  Result:=@GetNumberFunc;',
+  'end;',
+  'var',
+  '  i: longint;',
+  '  f: TFunctionInt;',
+  '  ff: TFunctionIntFunc;',
+  'begin',
+  '  i:=GetNumber; // omit ()',
+  '  i:=GetNumber();',
+  '  i:=GetNumberFunc()();',
+  '  i:=GetNumberFuncFunc()()();',
+  '  if i=GetNumberFunc()() then ;',
+  '  if GetNumberFunc()()=i then ;',
+  '  if i=GetNumberFuncFunc()()() then ;',
+  '  if GetNumberFuncFunc()()()=i then ;',
+  '  f:=nil;',
+  '  if f=nil then ;',
+  '  if nil=f then ;',
+  '  if Assigned(f) then ;',
+  '  f:=f;',
+  '  f:=@GetNumber;',
+  '  f:=GetNumberFunc; // not in Delphi',
+  '  f:=GetNumberFunc(); // not in Delphi',
+  '  f:=GetNumberFuncFunc()();',
+  '  if f=f then ;',
+  '  if i=f then ;',
+  '  if i=f() then ;',
+  '  if f()=i then ;',
+  '  if f()=f() then ;',
+  '  if f=@GetNumber then ;',
+  '  if @GetNumber=f then ;',
+  '  if f=GetNumberFunc then ;',
+  '  if f=GetNumberFunc() then ;',
+  '  if f=GetNumberFuncFunc()() then ;',
+  '  ff:=nil;',
+  '  if ff=nil then ;',
+  '  if nil=ff then ;',
+  '  ff:=ff;',
+  '  if ff=ff then ;',
+  '  ff:=@GetNumberFunc;',
+  '  ff:=GetNumberFuncFunc; // not in Delphi',
+  '  ff:=GetNumberFuncFunc();']);
   ParseProgram;
 end;
 
@@ -16520,6 +16524,19 @@ begin
     end;
 end;
 
+procedure TTestResolver.TestProcTypeAnonymous_FunctionFunctionFail;
+begin
+  exit;
+
+  StartProgram(false);
+  Add([
+  'var',
+  '  f: function:function:longint;',
+  'begin']);
+  CheckParserException('Expected "Identifier or file"',
+    nParserExpectTokenError);
+end;
+
 procedure TTestResolver.TestPointer;
 begin
   StartProgram(false);

packages/pastojs/tests/tcmodules.pas

@@ -847,6 +847,7 @@ type
     Procedure TestRTTI_Double;
     Procedure TestRTTI_ProcType;
     Procedure TestRTTI_ProcType_ArgFromOtherUnit;
+    Procedure TestRTTI_ProcTypeAnonymous;
     Procedure TestRTTI_EnumAndSetType;
     Procedure TestRTTI_EnumRange;
     Procedure TestRTTI_AnonymousEnumType;
@@ -30428,6 +30429,50 @@ begin
     '']) );
 end;
 
+procedure TTestModule.TestRTTI_ProcTypeAnonymous;
+begin
+  WithTypeInfo:=true;
+  StartProgram(false);
+  Add(['var',
+  '  ProcA: procedure;',
+  '  MethodB: procedure of object;',
+  '  ProcC: procedure; varargs;',
+  '  ProcD: procedure(i: longint; const j: string; var c: char; out d: double);',
+  '  ProcE: function: nativeint;',
+  '  p: pointer;',
+  'begin',
+  '  p:=typeinfo(proca);']);
+  ConvertProgram;
+  CheckSource('TestRTTI_ProcTypeAnonymous',
+    LinesToStr([ // statements
+    'this.$rtti.$ProcVar("ProcA$a", {',
+    '  procsig: rtl.newTIProcSig([])',
+    '});',
+    'this.ProcA = null;',
+    'this.$rtti.$MethodVar("MethodB$a", {',
+    '  procsig: rtl.newTIProcSig([]),',
+    '  methodkind: 0',
+    '});',
+    'this.MethodB = null;',
+    'this.$rtti.$ProcVar("ProcC$a", {',
+    '  procsig: rtl.newTIProcSig([], null, 2)',
+    '});',
+    'this.ProcC = null;',
+    'this.$rtti.$ProcVar("ProcD$a", {',
+    '  procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
+    '});',
+    'this.ProcD = null;',
+    'this.$rtti.$ProcVar("ProcE$a", {',
+    '  procsig: rtl.newTIProcSig([], rtl.nativeint)',
+    '});',
+    'this.ProcE = null;',
+    'this.p = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.p = $mod.$rtti["ProcA$a"];',
+    '']));
+end;
+
 procedure TTestModule.TestRTTI_EnumAndSetType;
 begin
   WithTypeInfo:=true;