[fpc-devel] Local classes and interfaces

[Blaise at blaise.ru]

On 19.12.2020 16:51, Sven Barth wrote:
> Considering that it's only intended for internal use, yes I'm aboard with that.

Here is the first change: http://hg.blaise.ru/public/fpc/rev/7c78bfdaed9a (attached).

Strictly speaking, some local classes and interfaces can be compiled without that -- the ICE 200204175 only occurs when they have their own entities such as nested classes (not used for Closures) and non-abstract methods:
-------8<-------
function Foo: TClass;
	type Local = class
		type Nested = class end;
		procedure Method;
	end;
	procedure Local.Method;
	begin
	end;
begin
	result := Local
end;

begin
	Foo
end.
-------8<-------

To observe the effect, one could temporarily use the second attached patch to force FPC to compile the above test case. The following internal names are generated for it:
VMT_$P$PROGRAM$_$FOO_$$_LOCAL // no change
VMT_$P$PROGRAM$_$FOO_$LOCAL_$__$$_NESTED // was: ICE
P$PROGRAM$_$FOO_$LOCAL_$__$$_METHOD // was: ICE
Please check that such names are in line with the intended format.

> I'd say in this case the bug is that the declaration of those two Cls<> types is allowed.

Looking at the excerpt from object_dec:
>         { objects and class types can't be declared local }
>         if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) and
>            not assigned(genericlist) then
>           Message(parser_e_no_local_objects);
"assigned(genericlist)" seems intentional. Maybe, it misses a check for generic instantiation; however:

> If I remember correctly *specializations* are already placed in the more nested scope if they use local types.

Judging solely by the internal names, that is not what happens.

> or at least that was the plan

If you were to implement that, you would encounter the same ICE.

-- 
βþ
-------------- next part --------------
# HG changeset patch
# User Blaise.ru
+ make_mangledname: allow for local classes & interfaces

diff -r 7b102c2fd615 -r 4990da1ff00c symdef.pas
--- a/symdef.pas
+++ b/symdef.pas
@@ -1535,36 +1535,42 @@
         prefix:='';
         if not assigned(st) then
          internalerror(200204212);
-        { sub procedures }
-        while (st.symtabletype in [localsymtable,parasymtable]) do
-         begin
-           if st.defowner.typ<>procdef then
-            internalerror(200204173);
-           { Add the full mangledname of procedure to prevent
-             conflicts with 2 overloads having both a nested procedure
-             with the same name, see tb0314 (PFV) }
-           s:=tprocdef(st.defowner).procsym.name;
-           s:=s+tprocdef(st.defowner).mangledprocparanames(Length(s));
-           if prefix<>'' then
-             prefix:=s+'_'+prefix
-           else
-             prefix:=s;
-           if length(prefix)>100 then
-             begin
-               crc:=0;
-               crc:=UpdateCrc32(crc,prefix[1],length(prefix));
-               prefix:='$CRC'+hexstr(crc,8);
-             end;
-           st:=st.defowner.owner;
-         end;
-        { object/classes symtable, nested type definitions in classes require the while loop }
-        while st.symtabletype in [ObjectSymtable,recordsymtable] do
-         begin
-           if not (st.defowner.typ in [objectdef,recorddef]) then
-            internalerror(200204174);
-           prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix;
-           st:=st.defowner.owner;
-         end;
+        repeat
+          { sub procedures }
+          while (st.symtabletype in [localsymtable,parasymtable]) do
+           begin
+             if st.defowner.typ<>procdef then
+              internalerror(200204173);
+             { Add the full mangledname of the routine to prevent
+               conflicts with two overloads both having a local entity
+               -- routine (tb0314), class, interface -- with the same name }
+             s:=tprocdef(st.defowner).procsym.name;
+             s:=s+tprocdef(st.defowner).mangledprocparanames(Length(s));
+             if prefix<>'' then
+               prefix:=s+'_'+prefix
+             else
+               prefix:=s;
+             if length(prefix)>100 then
+               begin
+                 crc:=0;
+                 crc:=UpdateCrc32(crc,prefix[1],length(prefix));
+                 prefix:='$CRC'+hexstr(crc,8);
+               end;
+             st:=st.defowner.owner;
+           end;
+          { object/classes symtable, nested type definitions in classes require the while loop }
+          while st.symtabletype in [ObjectSymtable,recordsymtable] do
+           begin
+             if not (st.defowner.typ in [objectdef,recorddef]) then
+              internalerror(200204174);
+             prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix;
+             st:=st.defowner.owner;
+           end;
+          { local classes & interfaces are possible (because of closures) }
+          if st.symtabletype<>localsymtable then
+            break;
+          prefix:='$'+prefix;
+        until false;
         { symtable must now be static or global }
         if not(st.symtabletype in [staticsymtable,globalsymtable]) then
           internalerror(200204175);
-------------- next part --------------
# HG changeset patch
# User Blaise.ru
TEST: allow local classes/interfaces

diff -r 4990da1ff00c -r 98b295988049 pdecobj.pas
--- a/pdecobj.pas
+++ b/pdecobj.pas
@@ -1428,9 +1428,9 @@
         current_specializedef:=nil;
 
         { objects and class types can't be declared local }
-        if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) and
+        {if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) and
            not assigned(genericlist) then
-          Message(parser_e_no_local_objects);
+          Message(parser_e_no_local_objects);}
 
         { reuse forward objectdef? }
         if assigned(fd) then
diff -r 4990da1ff00c -r 98b295988049 pdecsub.pas
--- a/pdecsub.pas
+++ b/pdecsub.pas
@@ -934,7 +934,7 @@
             { method  ? }
             srsym:=nil;
             if not assigned(astruct) and
-               (symtablestack.top.symtablelevel=main_program_level) and
+               //(symtablestack.top.symtablelevel=main_program_level) and
                try_to_consume(_POINT) then
              begin
                repeat