Merge remote-tracking branch 'origin/main' into wasm_js_promise_integration

compiler/pdecl.pas

@@ -912,12 +912,15 @@ implementation
                             Delphi-compatible }
                           hdef2:=tstoreddef(hdef).getcopy;
                           tobjectdef(hdef2).childof:=tobjectdef(hdef);
+                          tstoreddef(hdef2).orgdef:=tstoreddef(hdef);
                           hdef:=hdef2;
                         end
                       else
                         begin
-                          hdef:=tstoreddef(hdef).getcopy;
-                          { check if it is an ansistirng(codepage) declaration }
+                          hdef2:=tstoreddef(hdef).getcopy;
+                          tstoreddef(hdef2).orgdef:=tstoreddef(hdef);
+                          hdef:=hdef2;
+                          { check if it is an ansistring(codepage) declaration }
                           if is_ansistring(hdef) and try_to_consume(_LKLAMMER) then
                             begin
                               p:=comp_expr([ef_accept_equal]);

compiler/pdecobj.pas

@@ -730,11 +730,22 @@ implementation
         end;
 
       procedure check_inheritance_record_type_helper(var def:tdef);
+        var
+          tmp : tstoreddef;
         begin
           if (def.typ<>errordef) and assigned(current_objectdef.childof) then
             begin
               if def<>current_objectdef.childof.extendeddef then
                 begin
+                  { a type helper may extend a type alias of the type its
+                    parent type helper extends }
+                  tmp:=tstoreddef(def);
+                  while (df_unique in tmp.defoptions) and assigned(tstoreddef(tmp).orgdef) do
+                    begin
+                      if tmp.orgdef=current_objectdef.childof.extendeddef then
+                        exit;
+                      tmp:=tstoreddef(tmp.orgdef);
+                    end;
                   Message1(type_e_record_helper_must_extend_same_record,current_objectdef.childof.extendeddef.typename);
                   def:=generrordef;
                 end;

compiler/pdecsub.pas

@@ -545,6 +545,7 @@ implementation
         found,
         searchagain : boolean;
         st,
+        insertst,
         genericst: TSymtable;
         aprocsym : tprocsym;
         popclass : integer;
@@ -854,19 +855,23 @@ implementation
         hadspecialize:=false;
         addgendummy:=false;
 
+        { ensure that we don't insert into a withsymtable (can happen with
+          anonymous functions) }
+        checkstack:=symtablestack.stack;
+        while checkstack^.symtable.symtabletype in [withsymtable] do
+          checkstack:=checkstack^.next;
+        insertst:=checkstack^.symtable;
+
         if not assigned(genericdef) then
           begin
             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
+                if not (insertst.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);
+                str(insertst.symlist.count,orgsp);
                 orgsp:='__FPCINTERNAL__Anonymous_'+orgsp;
                 sp:=upper(orgsp);
                 spnongen:=sp;
@@ -1032,7 +1037,7 @@ implementation
                  if (potype=potype_operator)and(optoken=NOTOKEN) then
                    parse_operator_name;
 
-                 srsym:=tsym(symtablestack.top.Find(sp));
+                 srsym:=tsym(insertst.Find(sp));
 
                  { Also look in the globalsymtable if we didn't found
                    the symbol in the localsymtable }
@@ -1102,7 +1107,7 @@ implementation
                   operation }
                 if (potype=potype_operator) then
                   begin
-                    aprocsym:=Tprocsym(symtablestack.top.Find(sp));
+                    aprocsym:=Tprocsym(insertst.Find(sp));
                     if aprocsym=nil then
                       aprocsym:=cprocsym.create('$'+sp);
                   end
@@ -1115,7 +1120,7 @@ implementation
                   include(aprocsym.symoptions,sp_internal);
                 if addgendummy then
                   include(aprocsym.symoptions,sp_generic_dummy);
-                symtablestack.top.insertsym(aprocsym);
+                insertst.insertsym(aprocsym);
               end;
           end;
 
@@ -1176,7 +1181,7 @@ implementation
                   dummysym:=tsym(astruct.symtable.find(spnongen))
                 else
                   begin
-                    dummysym:=tsym(symtablestack.top.find(spnongen));
+                    dummysym:=tsym(insertst.find(spnongen));
                     if not assigned(dummysym) and
                         (symtablestack.top=current_module.localsymtable) and
                         assigned(current_module.globalsymtable) then
@@ -1190,7 +1195,7 @@ implementation
                     if assigned(astruct) then
                       astruct.symtable.insertsym(dummysym)
                     else
-                      symtablestack.top.insertsym(dummysym);
+                      insertst.insertsym(dummysym);
                   end
                 else if (dummysym.typ<>procsym) and
                     (
@@ -1282,8 +1287,8 @@ implementation
 
         { symbol options that need to be kept per procdef }
         pd.fileinfo:=procstartfilepos;
-        pd.visibility:=symtablestack.top.currentvisibility;
-        if symtablestack.top.currentlyoptional then
+        pd.visibility:=insertst.currentvisibility;
+        if insertst.currentlyoptional then
           include(pd.procoptions,po_optional);
 
         { parse parameters }

compiler/pparautl.pas

@@ -357,8 +357,13 @@ implementation
 
            { insert the name of the procedure as alias for the function result,
              we can't use realname because that will not work for compilerprocs
-             as the name is lowercase and unreachable from the code }
-           if (pd.proctypeoption<>potype_operator) or assigned(pd.resultname) then
+             as the name is lowercase and unreachable from the code;
+             don't insert this alias for an anonymous function unless an
+             explicit name is provided }
+           if (
+                 (pd.proctypeoption<>potype_operator) and
+                 not (po_anonymous in pd.procoptions)
+               ) or assigned(pd.resultname) then
              begin
                if assigned(pd.resultname) then
                  hs:=pd.resultname^

compiler/symdef.pas

@@ -138,6 +138,9 @@ interface
           genconstraintdata : tgenericconstraintdata;
           { this is Nil if the def has no RTTI attributes }
           rtti_attribute_list : trtti_attribute_list;
+          { original def for "type <name>" declarations }
+          orgdef          : tstoreddef;
+          orgdefderef     : tderef;
           constructor create(dt:tdeftyp;doregister:boolean);
           constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
           destructor  destroy;override;
@@ -2103,6 +2106,8 @@ implementation
          ppufile.getderef(typesymderef);
          ppufile.getset(tppuset2(defoptions));
          ppufile.getset(tppuset1(defstates));
+         if df_unique in defoptions then
+           ppufile.getderef(orgdefderef);
          if df_genconstraint in defoptions then
            begin
              genconstraintdata:=tgenericconstraintdata.create;
@@ -2273,6 +2278,8 @@ implementation
         oldintfcrc:=ppufile.do_crc;
         ppufile.do_crc:=false;
         ppufile.putset(tppuset1(defstates));
+        if df_unique in defoptions then
+          ppufile.putderef(orgdefderef);
         if df_genconstraint in defoptions then
           genconstraintdata.ppuwrite(ppufile);
         if [df_generic,df_specialization]*defoptions<>[] then
@@ -2340,6 +2347,7 @@ implementation
         if not registered then
           register_def;
         typesymderef.build(typesym);
+        orgdefderef.build(orgdef);
         genericdefderef.build(genericdef);
         if assigned(rtti_attribute_list) then
           rtti_attribute_list.buildderef;
@@ -2371,6 +2379,8 @@ implementation
         i : longint;
       begin
         typesym:=ttypesym(typesymderef.resolve);
+        if df_unique in defoptions then
+          orgdef:=tstoreddef(orgdefderef.resolve);
         if df_specialization in defoptions then
           genericdef:=tstoreddef(genericdefderef.resolve);
         if assigned(rtti_attribute_list) then

compiler/utils/ppuutils/ppudump.pp

@@ -2872,6 +2872,12 @@ begin
     end;
   writeln;
 
+  if df_unique in defoptions then
+    begin
+      write  ([space,'      OriginalDef : ']);
+      readderef(space);
+    end;
+
   if df_genconstraint in defoptions then
     begin
       ppufile.getset(tppuset1(genconstr));

tests/test/tanonfunc73.pp

@@ -0,0 +1,35 @@
+{ %NORUN }
+
+program tanonfunc73;
+
+{$mode objfpc}
+{$modeswitch anonymousfunctions}
+{$modeswitch functionreferences}
+
+type
+  TProc = reference to procedure;
+
+procedure Test;
+var
+  o: TObject;
+  p: TProc;
+begin
+  with o do begin
+    p := procedure
+         begin
+           Writeln('Hello World');
+         end;
+  end;
+end;
+
+var
+  o: TObject;
+  p: TProc;
+begin
+  with o do begin
+    p := procedure
+         begin
+           Writeln('Hello World');
+         end;
+  end;
+end.

tests/test/tthlp30.pp

@@ -0,0 +1,72 @@
+program tthlp30;
+
+{$mode objfpc}
+{$modeswitch typehelpers}
+
+type
+  Test1 = type LongInt;
+  Test2 = type LongInt;
+  Test3 = type Test1;
+
+  TLongIntHelper = type helper for LongInt
+    function TestA: LongInt;
+    function TestB: LongInt;
+  end;
+
+  TTest1Helper = type helper(TLongIntHelper) for Test1
+    function TestA: LongInt;
+  end;
+
+  TTest2Helper = type helper(TLongIntHelper) for Test2
+    function TestB: LongInt;
+  end;
+
+  TTest3Helper = type helper(TLongIntHelper) for Test3
+  end;
+
+function TTest2Helper.TestB: LongInt;
+begin
+  Result := 2;
+end;
+
+function TTest1Helper.TestA: LongInt;
+begin
+  Result := 2;
+end;
+
+function TLongIntHelper.TestA: LongInt;
+begin
+  Result := 1;
+end;
+
+function TLongIntHelper.TestB: LongInt;
+begin
+  Result := 1;
+end;
+
+var
+  l: LongInt;
+  t1: Test1;
+  t2: Test2;
+  t3: Test3;
+begin
+  if l.TestA <> 1 then
+    Halt(1);
+  if l.TestB <> 1 then
+    Halt(2);
+
+  if t1.TestA <> 2 then
+    Halt(3);
+  if t1.TestB <> 1 then
+    Halt(4);
+
+  if t2.TestA <> 1 then
+    Halt(5);
+  if t2.TestB <> 2 then
+    Halt(6);
+
+  if t3.TestA <> 1 then
+    Halt(7);
+  if t3.TestB <> 1 then
+    Halt(8);
+end.

tests/test/tthlp31.pp

@@ -0,0 +1,19 @@
+{ %FAIL }
+
+program tthlp31;
+
+{$mode objfpc}
+{$modeswitch typehelpers}
+
+type
+  Test = type LongInt;
+
+  TTestHelper = type helper for Test
+  end;
+
+  TLongIntHelper = type helper(TTestHelper) for LongInt
+  end;
+
+begin
+
+end.

tests/webtbs/tw40142.pp

@@ -0,0 +1,30 @@
+{ %NORUN }
+
+program tw40142;
+
+{$Mode objfpc}{$H+}
+{$ModeSwitch anonymousfunctions}
+{$ModeSwitch functionreferences}
+{$ModeSwitch nestedprocvars}
+
+type
+  TVoidFunc = reference to procedure;
+  TFuncMaker = reference to function(const thing: string): TVoidFunc;
+
+procedure main;
+  var
+    cool_bingo: TVoidFunc;
+    coolifier: TFuncMaker;
+  begin
+    coolifier := function (const thing: string) : TVoidFunc
+    begin
+      result := procedure begin writeln('cool ', thing) end;
+    end;
+    cool_bingo := coolifier('bingo');
+    cool_bingo();
+  end;
+
+begin
+  main;
+end.
+

tests/webtbs/tw40324.pp

@@ -0,0 +1,69 @@
+program tw40324;
+// This program compiles and runs in Delphi and in FPC. (at least should run in FPC)
+// It is intentionally designed this way.
+{$ifdef FPC}
+{$mode objfpc}{$H+}
+{$modeswitch functionreferences}
+{$modeswitch anonymousfunctions}
+  // {$warn 5036 off}// "Warning: (5036) Local variable "$Capturer" does not seem to be initialized"
+{$endif}
+// uses
+{$IFDEF UNIX}
+cthreads,
+{$ENDIF}
+  // Classes, Sysutils { you can add units after this };
+
+type
+  T_X = String; // Type of Test-variable X
+  TfuncS = reference to function: T_X;
+  TfuncF = reference to function(s: T_X): TfuncS;
+
+var f_inner: TfuncS;
+  f_outer: TfuncF;
+//------------------------------------------------------------------------------
+procedure caller;
+begin
+  f_inner();
+end;
+//------------------------------------------------------------------------------
+procedure main;
+
+var X: T_X;
+   // str:String;
+    f_outer: TfuncF;
+
+begin
+
+  X := '1234';
+
+  f_outer := function(s: T_X): TfuncS // This captures local and persistent copy of "X"
+  begin
+      Result := function: T_X
+      begin
+          Writeln(s);
+          Result := s;
+      end;
+      Writeln('Outer function was called');
+  end;
+  f_inner := f_outer(X); // This instantiates the outer function and f_inner and captures their local context.
+
+  X := '0'; // Erase the T_X content
+
+  Writeln('now calling f_inner');
+  caller(); // This line prints the T_X s=1234, which was captured by the outer function.
+               // f_inner will be called from an external context, this is just for test and demonstration
+end;
+//------------------------------------------------------------------------------
+begin
+  main;
+  Writeln('Now the context of "main()" is lost. Can we still print the variable "X"?');
+  if f_inner() = '1234' then
+    Writeln('Yes! :-)')
+  else begin
+    Writeln('No! :-(');
+    Halt(1);
+  end;
+
+  //readln;
+
+end.