+ initial support for anonymous functions, for now as essentially nested functions

Based on work by Blaise.ru

compiler/pdecsub.pas

@@ -57,7 +57,8 @@ interface
 
       tparse_proc_flag=(
         ppf_classmethod,
-        ppf_generic
+        ppf_generic,
+        ppf_anonymous
       );
       tparse_proc_flags=set of tparse_proc_flag;
 
@@ -871,7 +872,24 @@ implementation
 
         if not assigned(genericdef) then
           begin
-            consume_proc_name;
+            if ppf_anonymous in flags then
+              begin
+                checkstack:=symtablestack.stack;
+                while checkstack^.symtable.symtabletype in [withsymtable] do
+                  checkstack:=checkstack^.next;
+                if not (checkstack^.symtable.symtabletype in [localsymtable,staticsymtable]) then
+                  internalerror(2021050101);
+                { generate a unique name for the anonymous function; don't use
+                  something like file position however as this might be inside
+                  an include file that's included multiple times }
+                str(checkstack^.symtable.symlist.count,orgsp);
+                orgsp:='_$Anonymous$'+orgsp;
+                sp:=upper(orgsp);
+                spnongen:=sp;
+                orgspnongen:=orgsp;
+              end
+            else
+              consume_proc_name;
 
             { examine interface map: function/procedure iname.functionname=locfuncname }
             if assigned(astruct) and
@@ -1129,6 +1147,8 @@ implementation
         pd.struct:=astruct;
         pd.procsym:=aprocsym;
         pd.proctypeoption:=potype;
+        if ppf_anonymous in flags then
+          include(pd.procoptions,po_anonymous);
 
         if assigned(genericparams) then
           begin
@@ -1587,7 +1607,8 @@ implementation
                 message(parser_e_field_not_allowed_here);
                 consume_all_until(_SEMICOLON);
               end;
-            consume(_SEMICOLON);
+            if not (ppf_anonymous in flags) then
+              consume(_SEMICOLON);
           end;
 
         if locationstr<>'' then
@@ -1706,7 +1727,8 @@ implementation
                 message(parser_e_field_not_allowed_here);
                 consume_all_until(_SEMICOLON);
               end;
-            consume(_SEMICOLON);
+            if not (ppf_anonymous in flags) then
+              consume(_SEMICOLON);
           end;
 
         { we've parsed the final semicolon, so stop recording tokens }

compiler/pexpr.pas

@@ -80,7 +80,7 @@ implementation
        nmat,nadd,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,nutils,
        { parser }
        scanner,
-       pbase,pinline,ptype,pgenutil,procinfo,cpuinfo
+       pbase,pinline,ptype,pgenutil,psub,procinfo,cpuinfo
        ;
 
     function sub_expr(pred_level:Toperator_precedence;flags:texprflags;factornode:tnode):tnode;forward;
@@ -3583,6 +3583,7 @@ implementation
          again,
          updatefpos,
          nodechanged  : boolean;
+         oldprocvardef: tprocvardef;
       begin
         { can't keep a copy of p1 and compare pointers afterwards, because
           p1 may be freed and reallocated in the same place!  }
@@ -4187,6 +4188,30 @@ implementation
                  p1:=cinlinenode.create(in_objc_protocol_x,false,p1);
                end;
 
+             _PROCEDURE,
+             _FUNCTION:
+               begin
+                 if (block_type=bt_body) and
+                     (m_anonymous_functions in current_settings.modeswitches) then
+                   begin
+                     oldprocvardef:=getprocvardef;
+                     getprocvardef:=nil;
+                     pd:=read_proc([rpf_anonymous],nil);
+                     getprocvardef:=oldprocvardef;
+                     { assume that we try to get the address except if certain
+                       tokens follow that indicate a call }
+                     do_proc_call(pd.procsym,pd.owner,nil,not (token in [_POINT,_CARET,_LECKKLAMMER]),
+                                  again,p1,[],nil);
+                   end
+                 else
+                   begin
+                     Message(parser_e_illegal_expression);
+                     p1:=cerrornode.create;
+                     { recover }
+                     consume(token);
+                   end;
+               end
+
              else
                begin
                  Message(parser_e_illegal_expression);

compiler/psub.pas

@@ -93,7 +93,8 @@ interface
 
       tread_proc_flag = (
         rpf_classmethod,
-        rpf_generic
+        rpf_generic,
+        rpf_anonymous
       );
       tread_proc_flags = set of tread_proc_flag;
 
@@ -2610,6 +2611,12 @@ implementation
         current_module.procinfo:=current_procinfo;
         current_procinfo.procdef:=pd;
         isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level);
+        { an anonymous function is always considered as nested }
+        if po_anonymous in pd.procoptions then
+          begin
+            current_procinfo.force_nested;
+            isnestedproc:=true;
+          end;
 
         { Insert mangledname }
         pd.aliasnames.insert(pd.mangledname);
@@ -2667,6 +2674,7 @@ implementation
           into the parse_body routine is not done because of having better file position
           information available }
         if not current_procinfo.procdef.is_specialization and
+            not (po_anonymous in current_procinfo.procdef.procoptions) and
             (
               not assigned(current_procinfo.procdef.struct) or
               not (df_specialization in current_procinfo.procdef.struct.defoptions)
@@ -2711,6 +2719,8 @@ implementation
               include(result,ppf_classmethod);
             if rpf_generic in flags then
               include(result,ppf_generic);
+            if rpf_anonymous in flags then
+              include(result,ppf_anonymous);
           end;
 
       var
@@ -2771,10 +2781,11 @@ implementation
              { parse the directives that may follow }
              parse_proc_directives(result,pdflags);
 
-             { hint directives, these can be separated by semicolons here,
-               that needs to be handled here with a loop (PFV) }
-             while try_consume_hintdirective(result.symoptions,result.deprecatedmsg) do
-              Consume(_SEMICOLON);
+             if not (rpf_anonymous in flags) then
+               { hint directives, these can be separated by semicolons here,
+                 that needs to be handled here with a loop (PFV) }
+               while try_consume_hintdirective(result.symoptions,result.deprecatedmsg) do
+                Consume(_SEMICOLON);
 
              { Set calling convention }
              if parse_only then

compiler/symconst.pas

@@ -441,7 +441,9 @@ type
       "varargs" modifier or Mac-Pascal ".." parameter }
     po_variadic,
     { implicitly return same type as the class instance to which the message is sent }
-    po_objc_related_result_type
+    po_objc_related_result_type,
+    { Delphi-style anonymous function }
+    po_anonymous
   );
   tprocoptions=set of tprocoption;
 
@@ -1105,7 +1107,8 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has
       'po_is_auto_setter',{po_is_auto_setter}
       'po_noinline',{po_noinline}
       'C-style array-of-const', {po_variadic}
-      'objc-related-result-type' {po_objc_related_result_type}
+      'objc-related-result-type', {po_objc_related_result_type}
+      'po_anonymous' {po_anonymous}
     );
 
 implementation

compiler/utils/ppuutils/ppudump.pp

@@ -3032,7 +3032,8 @@ const
      (mask:po_is_auto_setter;  str: 'Automatically generated setter'),
      (mask:po_noinline;        str: 'Never inline'),
      (mask:po_variadic;        str: 'C VarArgs with array-of-const para'),
-     (mask:po_objc_related_result_type; str: 'Objective-C related result type')
+     (mask:po_objc_related_result_type; str: 'Objective-C related result type'),
+     (mask:po_anonymous;       str: 'Anonymous')
   );
 var
   proctypeoption  : tproctypeoption;