Support 'of object' and 'reference to' in procedural types

Source/DelphiAST.pas

@@ -70,6 +70,8 @@   TPasSyntaxTreeBuilder = class(TmwSimplePasParEx)
     procedure AddressOp; override;
     procedure AlignmentParameter; override;
     procedure AnonymousMethod; override;
+    procedure AnonymousMethodKind; override;
+    procedure AnonymousMethodType; override;
     procedure ArrayBounds; override;
     procedure ArrayConstant; override;
     procedure ArrayDimension; override;
@@ -175,6 +177,7 @@   TPasSyntaxTreeBuilder = class(TmwSimplePasParEx)
     procedure ParameterName; override;
     procedure PointerSymbol; override;
     procedure PointerType; override;
+    procedure ProceduralDirectiveOf; override;
     procedure ProceduralType; override;
     procedure ProcedureHeading; override;
     procedure ProcedureDeclarationSection; override;
@@ -294,7 +297,8 @@     TStringStreamHelper = class helper for TStringStream
 type
   TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atClassOf, atClass,
     atConst, atConstructor, atDestructor, atEnum, atInterface, atNil, atNumeric,
-    atOut, atPointer, atName, atString, atSubRange, atVar, atDispInterface);
+    atOut, atPointer, atName, atString, atSubRange, atVar, atDispInterface,
+    atOfObject, atReferenceTo);
 
 var
   AttributeValues: array[TAttributeValue] of string;
@@ -455,6 +459,26 @@ procedure TPasSyntaxTreeBuilder.AnonymousMethod;
   end;
 end;
 
+procedure TPasSyntaxTreeBuilder.AnonymousMethodKind;
+var
+  value: string;
+begin
+  value := LowerCase(Lexer.Token);
+  DoHandleString(value);
+  FStack.Peek.SetAttribute(anName, value);
+  inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.AnonymousMethodType;
+begin
+  FStack.Push(ntType).SetAttribute(anKind, AttributeValues[atReferenceTo]);
+  try
+    inherited;
+  finally
+    FStack.Pop;
+  end;
+end;
+
 procedure TPasSyntaxTreeBuilder.ArrayBounds;
 begin
   FStack.Push(ntBounds);
@@ -1890,6 +1914,12 @@ procedure TPasSyntaxTreeBuilder.PositionalArgument;
   end;
 end;
 
+procedure TPasSyntaxTreeBuilder.ProceduralDirectiveOf;
+begin
+  FStack.Peek.SetAttribute(anKind, AttributeValues[atOfObject]);
+  inherited;
+end;
+
 procedure TPasSyntaxTreeBuilder.ProceduralType;
 begin
   FStack.Push(ntType).SetAttribute(anName, Lexer.Token);

Source/SimpleParser/SimpleParser.pas

@@ -242,6 +242,7 @@   TmwSimplePasPar = class(TObject)
     procedure AncestorIdList; virtual;
     procedure AncestorId; virtual;
     procedure AnonymousMethod; virtual;
+    procedure AnonymousMethodKind; virtual;
     procedure AnonymousMethodType; virtual;
     procedure ArrayConstant; virtual;
     procedure ArrayBounds; virtual;
@@ -5591,20 +5592,25 @@ procedure TmwSimplePasPar.AnonymousMethod;
   Block;
 end;
 
+procedure TmwSimplePasPar.AnonymousMethodKind;
+begin
+  NextToken;
+end;
+
 procedure TmwSimplePasPar.AnonymousMethodType;
 begin
   ExpectedEx(ptReference);
   Expected(ptTo);
   case TokenID of
     ptProcedure:
       begin
-        NextToken;
+        AnonymousMethodKind;
         if TokenID = ptRoundOpen then
           FormalParameterList;
       end;
     ptFunction:
       begin
-        NextToken;
+        AnonymousMethodKind;
         if TokenID = ptRoundOpen then
           FormalParameterList;
         Expected(ptColon);

Test/Snippets/proceduraltypes.pas

@@ -0,0 +1,24 @@
+unit proceduraltypes;
+
+interface
+
+type
+  TPlainProc = procedure(const aX: Integer);
+  TPlainFunc = function(const aX: Integer): Boolean;
+
+  TMethodProc = procedure(const aX: Integer) of object;
+  TMethodFunc = function(const aX: Integer): Boolean of object;
+
+  TAnonProc = reference to procedure(const aX: Integer);
+  TAnonFunc = reference to function(const aX: Integer): Boolean;
+
+  TNoParamsProc = procedure;
+  TNoParamsMethod = procedure of object;
+  TNoParamsAnon = reference to procedure;
+
+  TStdCallProc = procedure(const aX: Integer); stdcall;
+  TStdCallMethod = procedure(const aX: Integer) of object; stdcall;
+
+implementation
+
+end.