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

compiler/ncnv.pas

@@ -2508,7 +2508,10 @@ implementation
                             not is_self_sym(tsym(pcapturedsyminfo(tprocdef(pd).capturedsyms[0])^.sym))
                           )
                         ) then
-                      internalerror(2021060801);
+                      begin
+                        result:=cerrornode.create;
+                        exit;
+                      end;
 
                     { so that insert_self_and_vmt_para correctly inserts the
                       Self, cause it otherwise skips that for anonymous functions }
@@ -2619,7 +2622,10 @@ implementation
                 else if tprocvardef(totypedef).is_addressonly then
                   begin
                     if assigned(tprocdef(pd).capturedsyms) and (tprocdef(pd).capturedsyms.count>0) then
-                      internalerror(2021060802);
+                      begin
+                        result:=cerrornode.create;
+                        exit;
+                      end;
 
                     { remove framepointer and Self parameters }
                     for i:=tprocdef(pd).parast.symlist.count-1 downto 0 do
@@ -3172,6 +3178,14 @@ implementation
                                  not(is_open_array(left.resultdef)) and
                                  not(is_array_constructor(left.resultdef)) and
                                  not(is_array_of_const(left.resultdef)) and
+                                 { if the from type is an anonymous function then
+                                   don't blindly convert it if the size is the same
+                                   as compare_defs_ext already determined that the
+                                   anonymous function is not compatible }
+                                 not(
+                                   (left.resultdef.typ=procdef) and
+                                   (po_anonymous in tprocdef(left.resultdef).procoptions)
+                                 ) and
                                  (left.resultdef.size=resultdef.size) and
                                  { disallow casts of const nodes }
                                  (not is_constnode(left) or

compiler/pparautl.pas

@@ -76,6 +76,8 @@ implementation
 
 
     procedure insert_funcret_para(pd:tabstractprocdef);
+      const
+        name_result='result';
       var
         storepos : tfileposinfo;
         vs       : tparavarsym;
@@ -87,7 +89,8 @@ implementation
            { if this was originally an anonymous function then this was already
              done earlier }
            not ((pd.typ=procdef) and tprocdef(pd).was_anonymous) and
-           paramanager.ret_in_param(pd.returndef,pd) then
+           paramanager.ret_in_param(pd.returndef,pd) and
+           not assigned(pd.parast.find(name_result)) then
          begin
            storepos:=current_tokenpos;
            if pd.typ=procdef then
@@ -113,7 +116,7 @@ implementation
            else
              paranr:=paranr_result;
            { Generate result variable accessing function result }
-           vs:=cparavarsym.create('$result',paranr,vs_var,pd.returndef,[vo_is_funcret,vo_is_hidden_para]);
+           vs:=cparavarsym.create('$'+name_result,paranr,vs_var,pd.returndef,[vo_is_funcret,vo_is_hidden_para]);
            pd.parast.insertsym(vs);
            { Store this symbol as funcretsym for procedures }
            if pd.typ=procdef then
@@ -125,12 +128,15 @@ implementation
 
 
     procedure insert_parentfp_para(pd:tabstractprocdef);
+      const
+        name_parentfp='parentfp';
       var
         storepos : tfileposinfo;
         vs       : tparavarsym;
         paranr   : longint;
       begin
-        if pd.parast.symtablelevel>normal_function_level then
+        if (pd.parast.symtablelevel>normal_function_level) and
+           not assigned(pd.parast.find(name_parentfp)) then
           begin
             storepos:=current_tokenpos;
             if pd.typ=procdef then
@@ -157,14 +163,14 @@ implementation
                not assigned(pd.owner.defowner) or
                (pd.owner.defowner.typ<>procdef) then
               begin
-                vs:=cparavarsym.create('$parentfp',paranr,vs_value
+                vs:=cparavarsym.create('$'+name_parentfp,paranr,vs_value
                       ,parentfpvoidpointertype,[vo_is_parentfp,vo_is_hidden_para]);
               end
             else
               begin
                 if not assigned(tprocdef(pd.owner.defowner).parentfpstruct) then
                   build_parentfpstruct(tprocdef(pd.owner.defowner));
-                vs:=cparavarsym.create('$parentfp',paranr,vs_value,
+                vs:=cparavarsym.create('$'+name_parentfp,paranr,vs_value,
                       tprocdef(pd.owner.defowner).parentfpstructptrtype,[vo_is_parentfp,vo_is_hidden_para]);
               end;
             pd.parast.insertsym(vs);
@@ -175,6 +181,11 @@ implementation
 
 
     procedure insert_self_and_vmt_para(pd:tabstractprocdef);
+      const
+        name_cmd='_cmd';
+        name_self='self';
+        name_block_literal='_block_literal';
+        name_vmt='vmt';
       var
         storepos : tfileposinfo;
         vs       : tparavarsym;
@@ -188,55 +199,65 @@ implementation
            is_objc_class_or_protocol(tprocdef(pd).struct) and
            (pd.parast.symtablelevel=normal_function_level) then
           begin
-            { insert Objective-C self and selector parameters }
-            vs:=cparavarsym.create('$_cmd',paranr_objc_cmd,vs_value,objc_seltype,[vo_is_msgsel,vo_is_hidden_para]);
-            pd.parast.insertsym(vs);
-            { make accessible to code }
-            sl:=tpropaccesslist.create;
-            sl.addsym(sl_load,vs);
-            aliasvs:=cabsolutevarsym.create_ref('_CMD',objc_seltype,sl);
-            include(aliasvs.varoptions,vo_is_msgsel);
-            tlocalsymtable(tprocdef(pd).localst).insertsym(aliasvs);
-
-            if (po_classmethod in pd.procoptions) then
-              { compatible with what gcc does }
-              hdef:=objc_idtype
-            else
-              hdef:=tprocdef(pd).struct;
+            if not assigned(pd.parast.find(name_cmd)) or
+                not assigned(pd.parast.find(name_self)) then
+              begin
+                { insert Objective-C self and selector parameters }
+                vs:=cparavarsym.create('$'+name_cmd,paranr_objc_cmd,vs_value,objc_seltype,[vo_is_msgsel,vo_is_hidden_para]);
+                pd.parast.insertsym(vs);
+                { make accessible to code }
+                sl:=tpropaccesslist.create;
+                sl.addsym(sl_load,vs);
+                aliasvs:=cabsolutevarsym.create_ref('_CMD',objc_seltype,sl);
+                include(aliasvs.varoptions,vo_is_msgsel);
+                tlocalsymtable(tprocdef(pd).localst).insertsym(aliasvs);
 
-            vs:=cparavarsym.create('$self',paranr_objc_self,vs_value,hdef,[vo_is_self,vo_is_hidden_para]);
-            pd.parast.insertsym(vs);
+                if (po_classmethod in pd.procoptions) then
+                  { compatible with what gcc does }
+                  hdef:=objc_idtype
+                else
+                  hdef:=tprocdef(pd).struct;
+
+                vs:=cparavarsym.create('$'+name_self,paranr_objc_self,vs_value,hdef,[vo_is_self,vo_is_hidden_para]);
+                pd.parast.insertsym(vs);
+              end;
           end
         else if (pd.typ=procvardef) and
            pd.is_methodpointer then
           begin
-            { Generate self variable }
-            vs:=cparavarsym.create('$self',paranr_self,vs_value,voidpointertype,[vo_is_self,vo_is_hidden_para]);
-            pd.parast.insertsym(vs);
+            if not assigned(pd.parast.find(name_self)) then
+              begin
+                { Generate self variable }
+                vs:=cparavarsym.create('$'+name_self,paranr_self,vs_value,voidpointertype,[vo_is_self,vo_is_hidden_para]);
+                pd.parast.insertsym(vs);
+              end;
           end
         { while only procvardefs of this type can be declared in Pascal code,
           internally we also generate procdefs of this type when creating
           block wrappers }
         else if (po_is_block in pd.procoptions) then
           begin
-            { generate the first hidden parameter, which is a so-called "block
-              literal" describing the block and containing its invocation
-              procedure  }
-            hdef:=cpointerdef.getreusable(get_block_literal_type_for_proc(pd));
-            { mark as vo_is_parentfp so that proc2procvar comparisons will
-              succeed when assigning arbitrary routines to the block }
-            vs:=cparavarsym.create('$_block_literal',paranr_blockselfpara,vs_value,
-              hdef,[vo_is_hidden_para,vo_is_parentfp]
-            );
-            pd.parast.insertsym(vs);
-            if pd.typ=procdef then
+            if not assigned(pd.parast.find('$'+name_block_literal)) then
               begin
-                { make accessible to code }
-                sl:=tpropaccesslist.create;
-                sl.addsym(sl_load,vs);
-                aliasvs:=cabsolutevarsym.create_ref('FPC_BLOCK_SELF',hdef,sl);
-                include(aliasvs.varoptions,vo_is_parentfp);
-                tlocalsymtable(tprocdef(pd).localst).insertsym(aliasvs);
+                { generate the first hidden parameter, which is a so-called "block
+                  literal" describing the block and containing its invocation
+                  procedure  }
+                hdef:=cpointerdef.getreusable(get_block_literal_type_for_proc(pd));
+                { mark as vo_is_parentfp so that proc2procvar comparisons will
+                  succeed when assigning arbitrary routines to the block }
+                vs:=cparavarsym.create('$'+name_block_literal,paranr_blockselfpara,vs_value,
+                  hdef,[vo_is_hidden_para,vo_is_parentfp]
+                );
+                pd.parast.insertsym(vs);
+                if pd.typ=procdef then
+                  begin
+                    { make accessible to code }
+                    sl:=tpropaccesslist.create;
+                    sl.addsym(sl_load,vs);
+                    aliasvs:=cabsolutevarsym.create_ref('FPC_BLOCK_SELF',hdef,sl);
+                    include(aliasvs.varoptions,vo_is_parentfp);
+                    tlocalsymtable(tprocdef(pd).localst).insertsym(aliasvs);
+                  end;
               end;
           end
         else
@@ -264,9 +285,10 @@ implementation
                          { no vmt for record/type helper constructors }
                          is_objectpascal_helper(tprocdef(pd).struct) and
                          (tobjectdef(tprocdef(pd).struct).extendeddef.typ<>objectdef)
-                       )) then
+                       )) and
+                   not assigned(pd.parast.find(name_vmt)) then
                  begin
-                   vs:=cparavarsym.create('$vmt',paranr_vmt,vs_value,cclassrefdef.create(tprocdef(pd).struct),[vo_is_vmt,vo_is_hidden_para]);
+                   vs:=cparavarsym.create('$'+name_vmt,paranr_vmt,vs_value,cclassrefdef.create(tprocdef(pd).struct),[vo_is_vmt,vo_is_hidden_para]);
                    pd.parast.insertsym(vs);
                  end;
 
@@ -291,10 +313,10 @@ implementation
                       vsp:=vs_var;
                     hdef:=selfdef;
                   end;
-                vs:=tparavarsym(pd.parast.find('self'));
+                vs:=tparavarsym(pd.parast.find(name_self));
                 if not assigned(vs) or (vs.typ<>paravarsym) or (vs.vardef<>hdef) then
                   begin
-                    vs:=cparavarsym.create('$self',paranr_self,vsp,hdef,[vo_is_self,vo_is_hidden_para]);
+                    vs:=cparavarsym.create('$'+name_self,paranr_self,vsp,hdef,[vo_is_self,vo_is_hidden_para]);
                     pd.parast.insertsym(vs);
                   end;
 
@@ -384,7 +406,11 @@ implementation
 
 
     procedure insert_hidden_para(p:TObject;arg:pointer);
+      const
+        name_high = 'high';
+        name_typinfo = 'typinfo';
       var
+        n   : tsymstr;
         hvs : tparavarsym;
         pd  : tabstractprocdef absolute arg;
       begin
@@ -415,19 +441,23 @@ implementation
            { needs high parameter ? }
            if paramanager.push_high_param(varspez,vardef,pd.proccalloption) then
              begin
+               n:=name_high+name;
+               if not assigned(owner.find(n)) then
+                 begin
 {$ifdef cpu8bitalu}
-               if is_shortstring(vardef) then
-                 hvs:=cparavarsym.create('$high'+name,paranr+1,vs_const,aluuinttype,[vo_is_high_para,vo_is_hidden_para])
-               else
+                   if is_shortstring(vardef) then
+                     hvs:=cparavarsym.create('$'+n,paranr+1,vs_const,aluuinttype,[vo_is_high_para,vo_is_hidden_para])
+                   else
 {$endif cpu8bitalu}
-                 hvs:=cparavarsym.create('$high'+name,paranr+1,vs_const,sizesinttype,[vo_is_high_para,vo_is_hidden_para]);
-               hvs.symoptions:=[];
-               owner.insertsym(hvs);
-               { don't place to register if it will be accessed from implicit finally block }
-               if (varspez=vs_value) and
-                  is_open_array(vardef) and
-                  is_managed_type(vardef) then
-                 hvs.varregable:=vr_none;
+                     hvs:=cparavarsym.create('$'+n,paranr+1,vs_const,sizesinttype,[vo_is_high_para,vo_is_hidden_para]);
+                   hvs.symoptions:=[];
+                   owner.insertsym(hvs);
+                   { don't place to register if it will be accessed from implicit finally block }
+                   if (varspez=vs_value) and
+                      is_open_array(vardef) and
+                      is_managed_type(vardef) then
+                     hvs.varregable:=vr_none;
+                 end;
              end
            else
             begin
@@ -448,9 +478,13 @@ implementation
                end;
               if (vardef.typ=formaldef) and (Tformaldef(vardef).typed) then
                 begin
-                  hvs:=cparavarsym.create('$typinfo'+name,paranr+1,vs_const,voidpointertype,
-                                          [vo_is_typinfo_para,vo_is_hidden_para]);
-                  owner.insertsym(hvs);
+                  n:=name_typinfo+name;
+                  if not assigned(owner.find(n)) then
+                    begin
+                      hvs:=cparavarsym.create('$'+n,paranr+1,vs_const,voidpointertype,
+                                              [vo_is_typinfo_para,vo_is_hidden_para]);
+                      owner.insertsym(hvs);
+                    end;
                 end;
             end;
          end;

compiler/procdefutil.pas

@@ -1138,6 +1138,7 @@ implementation
       invokename : tsymstr;
       i : longint;
       outerself,
+      fpsym,
       selfsym,
       sym : tsym;
       info : pcapturedsyminfo;
@@ -1146,7 +1147,6 @@ implementation
       invokedef,
       parentdef,
       curpd : tprocdef;
-      syms : tfpobjectlist;
     begin
       capturer:=nil;
       result:=funcref_intf_for_proc(pd,fileinfo_to_suffix(pd.fileinfo));
@@ -1203,24 +1203,24 @@ implementation
           pd.procsym.realname:=invokename;
           pd.parast.symtablelevel:=normal_function_level;
           pd.localst.symtablelevel:=normal_function_level;
-          { collect all hidden parameters and especially the self parameter (if any) }
+          { retrieve framepointer and self parameters if any }
+          fpsym:=nil;
           selfsym:=nil;
-          syms:=tfpobjectlist.create(false);
           for i:=0 to pd.parast.symlist.count-1 do
             begin
               sym:=tsym(pd.parast.symlist[i]);
               if sym.typ<>paravarsym then
                 continue;
-              if vo_is_self in tparavarsym(sym).varoptions then
-                selfsym:=sym
-              else if vo_is_hidden_para in tparavarsym(sym).varoptions then
-                syms.add(sym);
+              if vo_is_parentfp in tparavarsym(sym).varoptions then
+                fpsym:=sym
+              else if vo_is_self in tparavarsym(sym).varoptions then
+                selfsym:=sym;
+              if assigned(fpsym) and assigned(selfsym) then
+                break;
             end;
-          { get rid of the hidden parameters; they will be added again during
-            buildvmt of the capturer }
-          for i:=0 to syms.count-1 do
-            pd.parast.deletesym(tsym(syms[i]));
-          syms.free;
+          { get rid of the framepointer parameter }
+          if assigned(fpsym) then
+            pd.parast.deletesym(fpsym);
           outerself:=nil;
           { complain about all symbols that can't be captured and add the symbols
             to this procdefs capturedsyms if it isn't a top level function }

compiler/riscv/agrvgas.pas

@@ -245,13 +245,24 @@ unit agrvgas;
         result := inherited MakeCmdLine;
         Replace(result,'$ARCH',arch_str[current_settings.fputype=fpu_fd,current_settings.cputype]);
 {$ifdef RISCV32}
-        Replace(result,'$ABI','ilp32');
+      case target_info.abi of
+        abi_riscv_ilp32:
+          Replace(result,'$ABI','ilp32');
+        abi_riscv_ilp32f:
+          Replace(result,'$ABI','ilp32f');
+	else
+          Replace(result,'$ABI','ilp32d');
+      end;
 {$endif RISCV32}
 {$ifdef RISCV64}
-        if target_info.abi=abi_riscv_hf then
-          Replace(result,'$ABI','lp64d')
-        else
+      case target_info.abi of
+        abi_riscv_lp64:
           Replace(result,'$ABI','lp64');
+        abi_riscv_lp64f:
+          Replace(result,'$ABI','lp64f');
+	else
+          Replace(result,'$ABI','lp64d');
+      end;
 {$endif RISCV64}
       end;
 

compiler/systems/i_embed.pas

@@ -645,7 +645,7 @@ unit i_embed;
             first_parm_offset : 8;
             stacksize    : 262144;
             stackalign   : 4;
-            abi : abi_default;
+            abi : abi_riscv_ilp32;
             llvmdatalayout : 'e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32-S32';
           );
 
@@ -712,7 +712,7 @@ unit i_embed;
             first_parm_offset : 16;
             stacksize    : 262144;
             stackalign   : 8;
-            abi : abi_default;
+            abi : abi_riscv_lp64;
             llvmdatalayout : 'e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32-S32';
           );
 

compiler/systems/i_linux.pas

@@ -1309,7 +1309,7 @@ unit i_linux;
             first_parm_offset : 0;
             stacksize    : 32*1024*1024;
             stackalign   : 8;
-            abi : abi_riscv_hf;
+            abi : abi_riscv_ilp32;
             llvmdatalayout : 'e-p:32:32:32-i1:8:8-i8:8:32-i16:16:32-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-n32-S64';
           );
 

compiler/wasm32/agllvmmc.pas

@@ -241,7 +241,14 @@ implementation
             else
               begin
                 result:=result+'nan';
+{$ifndef CPUMIPS}
                 if fraction<>(int64(1) shl (fraction_bits-1)) then
+{$else CPUMIPS}
+                { Legacy mips fpu has a different representation of 'standard' nan }
+                { Signalling bit is clear to signify non-signalling }
+                { Standard non-signalling NaN thus has all other bits set }
+                if fraction<>((int64(1) shl (fraction_bits-1))-1) then
+{$endif CPUMIPS}
                   result:=result+'(0x'+HexStr(fraction,fraction_hexdigits)+')';
               end;
           end

packages/chm/src/chmfilewriter.pas

@@ -574,7 +574,7 @@ var
   Fini      : TMemIniFile;  // TMemInifile is more compatible with Delphi. Delphi's API based TIniFile fails on .hhp files.
   secs,strs : TStringList;
   i,j       : Integer;
-  section   : TSectionEnum;
+  _section  : TSectionEnum;
   nd        : TChmContextNode;
 
 begin
@@ -615,10 +615,10 @@ begin
 
   for i:=0 to secs.count-1 do
     begin
-      section:=FindSectionName(Uppercase(Secs[i]));
-      if section<>secunknown then
+      _section:=FindSectionName(Uppercase(Secs[i]));
+      if _section<>secunknown then
         fini.readsectionvalues(secs[i] ,strs);
-      case section of
+      case _section of
       secOptions   : readinioptions(strs);
       secWindows   : for j:=0 to strs.count-1 do
                        FWindows.add(TCHMWindow.Create(strs[j]));

packages/chm/src/chmls.lpr

@@ -40,7 +40,7 @@ type
   { TListObject }
 
   TListObject = class
-    Section  : Integer;
+    _Section : Integer;
     count    : integer;
     donotpage: boolean;
     nameonly : boolean;
@@ -196,7 +196,7 @@ procedure TListObject.OnFileEntry(Name: String; Offset, UncompressedSize,
   ASection: Integer);
 begin
   Inc(Count);
-  if (Section > -1) and (ASection <> Section) then Exit;
+  if (_Section > -1) and (ASection <> _Section) then Exit;
   if (Count = 1) or ((Count mod 40 = 0) and not donotpage) then
     begin
       Write(StdErr, '<Section> ');
@@ -274,7 +274,7 @@ end;
 var donotpage:boolean=false;
     name_only :boolean=false;
 
-procedure ListChm(Const Name:string;Section:Integer);
+procedure ListChm(Const Name:string;_Section:Integer);
 var
   ITS: TITSFReader;
   Stream: TFileStream;
@@ -289,7 +289,7 @@ begin
 
   Stream := TFileStream.Create(name, fmOpenRead);
   JunkObject := TListObject.Create;
-  JunkObject.Section:=Section;
+  JunkObject._Section:=_Section;
   JunkObject.Count:=0;
   JunkObject.DoNotPage:=DoNotPage;
   JunkObject.NameOnly:=Name_Only;
@@ -1002,7 +1002,7 @@ Var
   Params,
   OptionIndex : Longint;
   cmd         : TCmdEnum;
-  section     : Integer = -1;
+  _section    : Integer = -1;
 
 // Start of program
 begin
@@ -1043,15 +1043,15 @@ begin
     case cmd of
       cmdlist : begin
                   case length(localparams) of
-                    1 : ListChm(localparams[0],Section);
+                    1 : ListChm(localparams[0],_Section);
                     2 : begin
-                          if not TryStrToInt(localparams[1],section) then
+                          if not TryStrToInt(localparams[1],_section) then
                             begin
                               writeln(stderr,' Invalid value for section ',localparams[2]);
                               usage;
                               halt(1);
                             end;
-                          ListChm(localparams[0],Section);
+                          ListChm(localparams[0],_Section);
                         end;
                   else
                     WrongNrParam(cmdnames[cmd],length(localparams));

packages/chm/src/chmreader.pas

@@ -50,7 +50,7 @@ type
   end;
   { TITSFReader }
 
-  TFileEntryForEach = procedure(Name: String; Offset, UncompressedSize, Section: Integer) of object;
+  TFileEntryForEach = procedure(Name: String; Offset, UncompressedSize, _Section: Integer) of object;
 
   TITSFReader = class(TObject)
   protected

packages/fcl-base/src/syncobjs.pp

@@ -100,7 +100,7 @@ implementation
 {$ifdef MSWindows}
 uses Windows;
 
-function CoWaitForMultipleObjects(nCount:DWORD; lpHandles : PWOHandleArray; bWaitAll:WINBOOL; dwMilliseconds:DWORD):DWORD; external 'kernel32' name 'CoWaitForMultipleObjects';
+function CoWaitForMultipleHandles(dwFlags, dwTimeout: DWORD; cHandles: ULONG; pHandles: PWOHandleArray; out lpdwindex: DWORD): HRESULT; stdcall; external 'ole32.dll' name 'CoWaitForMultipleHandles';
 {$endif}
 
 
@@ -204,30 +204,51 @@ end;
 
 {$IFDEF MSWINDOWS}
 class function THandleObject.WaitForMultiple(const HandleObjs: THandleObjectArray; Timeout: Cardinal; AAll: Boolean; out SignaledObj: THandleObject; UseCOMWait: Boolean = False; Len: Integer = 0): TWaitResult;
+const COWAIT_DEFAULT = 0;
+      COWAIT_WAITALL = 1;
+      RPC_S_CALLPENDING = HRESULT($80010115);
 var
-  ret: Integer;
-  AmountHandles: Integer;
+  HandleIndex: SizeInt;
+  ret, CoWaitFlags, SignaledIndex: DWord;
+  WOHandles: TWOHandleArray;
 begin
-  AmountHandles := Length(HandleObjs);
-  if AmountHandles = 0 then
+  if Len = 0 then
+    Len := Length(HandleObjs);
+
+  if Len = 0 then
     raise ESyncObjectException.Create(SErrEventZeroNotAllowed);
 
-  if AmountHandles > MAXIMUM_WAIT_OBJECTS then
+  if Len > Length(HandleObjs) then
+    raise ESyncObjectException.Create(SErrEventTooManyHandles);
+
+  if Len > MAXIMUM_WAIT_OBJECTS then
     raise ESyncObjectException.CreateFmt(SErrEventMaxObjects, [MAXIMUM_WAIT_OBJECTS]);
 
-  if Len > AmountHandles then
-    raise ESyncObjectException.Create(SErrEventTooManyHandles);
+  for HandleIndex := 0 to Len - 1 do
+    WOHandles[HandleIndex] := Windows.HANDLE(HandleObjs[HandleIndex].Handle);
 
   // what about UseCOMWait?
-  {$IFDEF MSWINDOWS}
   if UseCOMWait Then
     begin
-      SetLastError(ERROR_SUCCESS); // only for "alertable" objects
-      ret := CoWaitForMultipleObjects(Len, @HandleObjs, AAll, Timeout);
-    end
-  else
-  {$ENDIF}
-    ret := WaitForMultipleObjects(Len, @HandleObjs, AAll, Timeout);
+      SetLastError(ERROR_SUCCESS); // workaround for mutexes, see docs on CoWaitForMultipleHandles.
+      CoWaitFlags := COWAIT_DEFAULT;
+      if AAll then
+        CoWaitFlags := CoWaitFlags or COWAIT_WAITALL;
+      case CoWaitForMultipleHandles(CoWaitFlags, Timeout, Len, @WOHandles, SignaledIndex) of
+        S_OK:
+          begin
+            if not AAll then
+              SignaledObj := HandleObjs[SignaledIndex];
+            Exit(wrSignaled);
+          end;
+        RPC_S_CALLPENDING:
+          Exit(wrTimeout);
+        else
+          Exit(wrError);
+      end;
+    end;
+
+  ret := WaitForMultipleObjects(Len, @WOHandles, AAll, Timeout);
 
   if (ret >= WAIT_OBJECT_0) and (ret < (WAIT_OBJECT_0 + Len)) then
     begin
@@ -245,13 +266,9 @@ begin
 
   case ret of
     WAIT_TIMEOUT:
-      begin
-        Result := wrTimeout;
-      end;
-    Integer(WAIT_FAILED): // w/o: Warning: Range check error while evaluating constants (4294967295 must be between -2147483648 and 2147483647)
-      begin
-        Result := wrError;
-      end;
+      Result := wrTimeout;
+    else
+      Result := wrError;
   end;
 end;
 {$endif}

packages/fcl-pdf/examples/.gitignore

@@ -3,3 +3,5 @@ testfppdf
 *.exe
 *.pdf
 fonts
+lib
+pdfdump

packages/fcl-pdf/examples/pdfdump.pp

@@ -382,7 +382,7 @@ begin
     // P.ResolveObjects:=False;
     P.ParseDocument(Doc);
     if isPageText in FSections then
-      P.ResolveToUnicodeCMaps(Doc);
+      P.DoResolveToUnicodeCMaps(Doc);
     For S in FSections do
       begin
       Case s of

packages/fcl-pdf/examples/testfppdf.lpr

@@ -27,6 +27,8 @@ uses
 
 type
 
+  { TPDFTestApp }
+
   TPDFTestApp = class(TCustomApplication)
   private
     FPage: integer;
@@ -42,6 +44,7 @@ type
     function    SetUpDocument: TPDFDocument;
     procedure   SaveDocument(D: TPDFDocument);
     procedure   EmptyPage;
+    procedure   TableOfContents(D: TPDFDocument; APage: integer);
     procedure   SimpleText(D: TPDFDocument; APage: integer);
     procedure   SimpleLinesRaw(D: TPDFDocument; APage: integer);
     procedure   SimpleLines(D: TPDFDocument; APage: integer);
@@ -62,7 +65,7 @@ var
   Application: TPDFTestApp;
 
 const
-  cPageCount: integer = 8;
+  cPageCount: integer = 9;
 
 function TPDFTestApp.SetUpDocument: TPDFDocument;
 var
@@ -141,6 +144,37 @@ begin
   end;
 end;
 
+procedure TPDFTestApp.TableOfContents(D: TPDFDocument; APage: integer);
+const
+  pagesarr: array [1..8] of String = ('Sample Text', 'Basic Shapes', 'Advanced Drawing',
+    'Sample Line Drawing (DrawLineStyle)', 'Sample Line Drawing (DrawLine)', 'Sample Image Support',
+    'Matrix transform', 'Landscape Page');
+var
+  P : TPDFPage;
+  FtTitle, FtText, i: integer;
+begin
+  P := D.Pages[APage];
+
+  // create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
+  FtTitle := D.AddFont('Helvetica');
+  FtText := D.AddFont('Courier');
+
+  { Page title }
+  P.SetFont(FtTitle, 23);
+  P.SetColor(clBlack, false);
+  P.WriteText(25, 20, 'Table of contents');
+
+  // -----------------------------------
+  { references to document pages }
+  P.SetFont(FtText, 12);
+  P.SetColor(clBlack, false);
+  for i := Low(pagesarr) to High(pagesarr) do
+  begin
+    P.WriteText(25, 40 + 10 * i, pagesarr[i] + StringOfChar('.', 60 - Length(pagesarr[i])) + IntToStr(i));
+    P.AddInternalLink(25, 40 + 10 * i, 160, 5, i, false);
+  end;
+end;
+
 { all units of measure are in millimeters }
 procedure TPDFTestApp.SimpleText(D: TPDFDocument; APage: integer);
 var
@@ -837,14 +871,15 @@ begin
 
     if FPage = -1 then
     begin
-      SimpleText(FDoc, 0);
-      SimpleShapes(FDoc, 1);
-      AdvancedShapes(FDoc, 2);
-      SimpleLines(FDoc, 3);
-      SimpleLinesRaw(FDoc, 4);
-      SimpleImage(FDoc, 5);
-      SampleMatrixTransform(FDoc, 6);
-      SampleLandscape(FDoc, 7);
+      TableOfContents(FDoc, 0);
+      SimpleText(FDoc, 1);
+      SimpleShapes(FDoc, 2);
+      AdvancedShapes(FDoc, 3);
+      SimpleLines(FDoc, 4);
+      SimpleLinesRaw(FDoc, 5);
+      SimpleImage(FDoc, 6);
+      SampleMatrixTransform(FDoc, 7);
+      SampleLandscape(FDoc, 8);
     end
     else
     begin

packages/fcl-pdf/src/fppdf.pp

@@ -785,6 +785,8 @@ type
     procedure CubicCurveToY(ACtrl1, ATo: TPDFCoord; const ALineWidth: TPDFFloat; AStroke: Boolean = True); overload;
     { Define a rectangle that becomes a clickable hotspot, referencing the URI argument. }
     Procedure AddExternalLink(const APosX, APosY, AWidth, AHeight: TPDFFloat; const AURI: string; ABorder: boolean = false);
+    { Define a rectangle that becomes a clickable hotspot, referencing the document page. }
+    Procedure AddInternalLink(const APosX, APosY, AWidth, AHeight: TPDFFloat; const APageIndex: Integer; ABorder: boolean = false);
     { This returns the paper height, converted to whatever UnitOfMeasure is set too }
     function GetPaperHeight: TPDFFloat;
     Function HasImages : Boolean;
@@ -908,9 +910,11 @@ type
     FHeight: TPDFFloat;
     FURI: string;
     FBorder: boolean;
+    FExternalLink: Boolean;
   public
     constructor Create(const ADocument: TPDFDocument); override; overload;
-    constructor Create(const ADocument: TPDFDocument; const ALeft, ABottom, AWidth, AHeight: TPDFFloat; const AURI: String; const ABorder: Boolean = false); overload;
+    constructor Create(const ADocument: TPDFDocument; const ALeft, ABottom, AWidth, AHeight: TPDFFloat; const AURI: String; const ABorder: Boolean = false;
+      const AExternalLink: Boolean = true); overload;
   end;
 
 
@@ -2146,7 +2150,7 @@ begin
 end;
 
 constructor TPDFAnnot.Create(const ADocument: TPDFDocument; const ALeft, ABottom, AWidth, AHeight: TPDFFloat;
-  const AURI: String; const ABorder: Boolean);
+  const AURI: String; const ABorder: Boolean; const AExternalLink: Boolean);
 begin
   Create(ADocument);
   FLeft := ALeft;
@@ -2155,6 +2159,7 @@ begin
   FHeight := AHeight;
   FURI := AURI;
   FBorder := ABorder;
+  FExternalLink := AExternalLink;
 end;
 
 { TPDFAnnotList }
@@ -2806,6 +2811,21 @@ begin
   Annots.Add(an);
 end;
 
+procedure TPDFPage.AddInternalLink(const APosX, APosY, AWidth, AHeight: TPDFFloat;
+    const APageIndex: Integer; ABorder: boolean);
+var
+  an: TPDFAnnot;
+  p1, p2: TPDFCoord;
+begin
+  p1 := Matrix.Transform(APosX, APosY);
+  DoUnitConversion(p1);
+  p2.X := AWidth;
+  p2.Y := AHeight;
+  DoUnitConversion(p2);
+  an := TPDFAnnot.Create(Document, p1.X, p1.Y, p2.X, p2.Y, Format('[%d]', [APageIndex]), ABorder, False);
+  Annots.Add(an);
+end;
+
 function TPDFPage.GetPaperHeight: TPDFFloat;
 begin
   case FUnitOfMeasure of
@@ -5635,9 +5655,17 @@ begin
 
   ADict := CreateDictionary;
   lDict.AddElement('A', ADict);
-  ADict.AddName('Type', 'Action');
-  ADict.AddName('S', 'URI');
-  ADict.AddString('URI', an.FURI);
+  if an.FExternalLink then
+  begin
+    ADict.AddName('Type', 'Action');
+    ADict.AddName('S', 'URI');
+    ADict.AddString('URI', an.FURI);
+  end
+  else
+  begin
+    ADict.AddName('S', 'GoTo');
+    ADict.AddName('D' + an.FURI, '');
+  end;
 
   result := GlobalXRefCount-1;
 end;

rtl/i386/i386.inc

@@ -2031,48 +2031,38 @@ procedure fpc_cpucodeinit;
 {$define FPC_SYSTEM_HAS_ANSISTR_DECR_REF}
 Procedure fpc_AnsiStr_Decr_Ref (Var S : Pointer); [Public,Alias:'FPC_ANSISTR_DECR_REF']; compilerproc; nostackframe; assembler;
 asm
-        cmpl    $0,(%eax)
-        je      .Lquit
-        pushl   %esi
-        movl    (%eax),%esi
-        subl    $12,%esi           // points to start of allocation
+        movl    (%eax),%edx
+        testl   %edx,%edx
+        jz      .Lquit
         movl    $0,(%eax)          // s:=nil
-        cmpl    $0,4(%esi)         // exit if refcount<0
-        jl      .Lj3596
+        cmpl    $0,-8(%edx)        // exit if refcount<0
+        jl      .Lquit
   {$ifdef FPC_PIC}
-	pushl	%ebx
-        call	fpc_geteipasebx
-        addl	$_GLOBAL_OFFSET_TABLE_,%ebx
-        movl	ismultithread@GOT(%ebx),%ebx
-        movl	(%ebx),%ebx
-        cmp	$0, %ebx
-	popl    %ebx
+        call	fpc_geteipasecx
+        addl	$_GLOBAL_OFFSET_TABLE_,%ecx
+        movl	ismultithread@GOT(%ecx),%ecx
+        cmpl	$0,(%ecx)
   {$else FPC_PIC}
         cmpl    $0,ismultithread
   {$endif FPC_PIC}
-        jne     .Lj3610
-        decl    4(%esi)
-        je      .Lj3620
-        jmp     .Lj3596
-.Lj3610:
-        leal    4(%esi),%eax
-        call    cpudeclocked
-        testb   %al,%al
-        je      .Lj3596
-.Lj3620:
-        movl    %esi,%eax
-        { freemem is not an assembler leaf function like fpc_geteipasebx and cpudeclocked, so it
+        je      .Lskiplock
+        .byte   0xF0               // LOCK prefix, jumped over if IsMultiThread = false. FPC assembler does not accept disjoint LOCK mnemonic.
+.Lskiplock:
+        decl    -8(%edx)
+        jz      .Lfree
+.Lquit:
+        ret
+.Lfree:
+        leal    -12(%edx),%eax     // points to start of allocation
+        { freemem is not an assembler leaf function like fpc_geteipasecx, so it
           needs to be called with proper stack alignment }
 {$ifdef FPC_SYSTEM_STACKALIGNMENT16}
-        leal    -8(%esp),%esp
-{$endif FPC_SYSTEM_STACKALIGNMENT16}
+        leal    -12(%esp),%esp
         call    FPC_FREEMEM
-{$ifdef FPC_SYSTEM_STACKALIGNMENT16}
-        leal    8(%esp),%esp
+        leal    12(%esp),%esp
+{$else  FPC_SYSTEM_STACKALIGNMENT16}
+        jmp     FPC_FREEMEM        // can perform a tail call
 {$endif FPC_SYSTEM_STACKALIGNMENT16}
-.Lj3596:
-        popl    %esi
-.Lquit:
 end;
 
 function fpc_truely_ansistr_unique(Var S : Pointer): Pointer; forward;

rtl/win/systhrd.inc

@@ -545,25 +545,25 @@ end;
 type 
       PWOHandleArray = ^THandle;
 
-function CoWaitForMultipleObjects(nCount:DWORD; lpHandles : PWOHandleArray; bWaitAll:LONGBOOL; dwMilliseconds:DWORD):DWORD; external 'ole32.dll' name 'CoWaitForMultipleObjects';
+function CoWaitForMultipleHandles(dwFlags, dwTimeout: DWORD; cHandles: uint32; pHandles: PWOHandleArray; out lpdwindex: DWORD): HRESULT; stdcall; external 'ole32.dll' name 'CoWaitForMultipleHandles';
 
 function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate;UseCOMWait: Boolean = False) : longint;
-
-var ret : Integer;
+const COWAIT_DEFAULT = 0;
+      RPC_S_CALLPENDING = HRESULT($80010115);
+var SignaledIndex : DWORD;
 begin
    if UseComWait Then
-     ret:=CoWaitForMultipleObjects(1,PWOHandleArray(@state), True, Timeout)
+     case CoWaitForMultipleHandles(COWAIT_DEFAULT, Timeout, 1, PWOHandleArray(@state), SignaledIndex) of
+       S_OK: Result := wrSignaled;
+       RPC_S_CALLPENDING: Result := wrTimeout;
+       else Result := wrError;
+     end
    else 
-     ret:=WaitForSingleObject(THandle(state), Timeout);
-
-   case ret of
-    WAIT_ABANDONED: Result := wrAbandoned;
-    WAIT_OBJECT_0: Result := wrSignaled;
-    WAIT_TIMEOUT: Result := wrTimeout;
-    WAIT_FAILED: Result := wrError;
-  else
-    Result := wrError;
-  end;
+     case WaitForSingleObject(THandle(state), Timeout) of
+       WAIT_OBJECT_0: Result := wrSignaled;
+       WAIT_TIMEOUT: Result := wrTimeout;
+       else result := wrError; { WAIT_FAILED or any other value. Note that only mutex waits can return WAIT_ABANDONED. }
+     end;
 end;
 
 function intRTLEventCreate: PRTLEvent;

rtl/x86_64/x86_64.inc

@@ -1009,20 +1009,10 @@ function declocked(var l : longint) : boolean;assembler; nostackframe;
 {$else FPC_PIC}
      cmpl       $0,IsMultithread(%rip)
 {$endif FPC_PIC}
-{$ifndef win64}
-     mov        %rdi, %rcx
-{$endif win64}
-     jz         .Ldeclockednolock
-     lock
-     decl       (%rcx)
-     setzb      %al
-     ret
-{$ifndef VER3_2}
-    .p2align 4,,10
-{$endif VER3_2}
-    .p2align 3
-.Ldeclockednolock:
-     decl       (%rcx)
+     jz         .Ldeclockedskiplock
+     .byte      0xF0 // LOCK prefix.
+.Ldeclockedskiplock:
+     decl       {$ifdef win64} (%rcx) {$else} (%rdi) {$endif}
      setzb      %al
   end;
 
@@ -1038,20 +1028,10 @@ function declocked(var l : int64) : boolean;assembler; nostackframe;
 {$else FPC_PIC}
      cmpl       $0,IsMultithread(%rip)
 {$endif FPC_PIC}
-{$ifndef win64}
-     mov        %rdi, %rcx
-{$endif win64}
-     jz         .Ldeclockednolock
-     lock
-     decq       (%rcx)
-     setzb      %al
-     ret
-{$ifndef VER3_2}
-    .p2align 4,,10
-{$endif VER3_2}
-    .p2align 3
-.Ldeclockednolock:
-     decq       (%rcx)
+     jz         .Ldeclockedskiplock
+     .byte      0xF0 // LOCK prefix.
+.Ldeclockedskiplock:
+     decq       {$ifdef win64} (%rcx) {$else} (%rdi) {$endif}
      setzb      %al
   end;
 
@@ -1068,19 +1048,10 @@ procedure inclocked(var l : longint);assembler; nostackframe;
 {$else FPC_PIC}
      cmpl       $0,IsMultithread(%rip)
 {$endif FPC_PIC}
-{$ifndef win64}
-     mov        %rdi, %rcx
-{$endif win64}
-     jz         .Linclockednolock
-     lock
-     incl       (%rcx)
-     ret
-{$ifndef VER3_2}
-    .p2align 4,,10
-{$endif VER3_2}
-    .p2align 3
-.Linclockednolock:
-     incl       (%rcx)
+     jz         .Linclockedskiplock
+     .byte      0xF0 // LOCK prefix.
+.Linclockedskiplock:
+     incl       {$ifdef win64} (%rcx) {$else} (%rdi) {$endif}
   end;
 
 
@@ -1096,19 +1067,10 @@ procedure inclocked(var l : int64);assembler; nostackframe;
 {$else FPC_PIC}
      cmpl       $0,IsMultithread(%rip)
 {$endif FPC_PIC}
-{$ifndef win64}
-     mov        %rdi, %rcx
-{$endif win64}
-     jz         .Linclockednolock
-     lock
-     incq       (%rcx)
-     ret
-{$ifndef VER3_2}
-    .p2align 4,,10
-{$endif VER3_2}
-    .p2align 3
-.Linclockednolock:
-     incq       (%rcx)
+     jz         .Linclockedskiplock
+     .byte      0xF0 // LOCK prefix.
+.Linclockedskiplock:
+     incq       {$ifdef win64} (%rcx) {$else} (%rdi) {$endif}
   end;
 
 

tests/webtbf/tw40221a.pp

@@ -0,0 +1,15 @@
+{ %FAIL }
+
+{$mode objfpc} {$modeswitch anonymousfunctions}
+procedure Main;
+var
+	c: int32;
+begin
+	c := 12;
+	TProcedure(procedure begin writeln(c); end);
+end;
+
+begin
+	Main;
+end.
+

tests/webtbf/tw40221b.pp

@@ -0,0 +1,17 @@
+{ %FAIL }
+
+{$mode objfpc} {$modeswitch anonymousfunctions}
+procedure Main;
+type
+  TProcMethod = procedure of object;
+var
+	c: int32;
+begin
+	c := 12;
+	TProcMethod(procedure begin writeln(c); end);
+end;
+
+begin
+	Main;
+end.
+

tests/webtbs/tw40143.pp

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

tests/webtbs/tw40144.pp

@@ -0,0 +1,36 @@
+{ %NORUN }
+
+program tw40144;
+
+{$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
+    cool_bingo := default(TVoidFunc);
+    coolifier := default(TFuncMaker);
+    coolifier := function (const thing: string): TVoidFunc
+    var
+      func: TVoidFunc;
+    begin
+      result := default(TVoidFunc); // <-- This is line 23
+      func := procedure begin writeln('cool ', thing) end;
+      result := func;
+    end;
+    cool_bingo := coolifier('bingo');
+    cool_bingo();
+  end;
+
+begin
+  main;
+end.
+

tests/webtbs/tw40145.pp

@@ -0,0 +1,35 @@
+{ %NORUN }
+
+program tw40145;
+
+{$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
+    cool_bingo := default(TVoidFunc);
+    coolifier := default(TFuncMaker);
+    coolifier := function (const thing: string): TVoidFunc
+    var
+      func: TVoidFunc;
+    begin
+      func := procedure begin writeln('cool ', thing) end;
+      result := func; // <-- This is line 24
+    end;
+    cool_bingo := coolifier('bingo');
+    cool_bingo();
+  end;
+
+begin
+  main;
+end.
+

tests/webtbs/tw40308.pp

@@ -0,0 +1,25 @@
+program tw40308;
+
+{$mode delphi}
+{$modeswitch anonymousfunctions}
+{$modeswitch functionreferences}
+
+//uses
+//  SysUtils;
+
+type
+  TFunc1 = reference to function (P1: Integer): String;
+
+function GetTestFunc1(P2: Integer): TFunc1;
+begin
+  Result := function (P1: Integer): String begin
+      Result := '3'; // <-- Error: Internal error 2011010304
+      //Result := IntToStr(P1 + P2);
+    end;
+end;
+
+begin
+  if GetTestFunc1(1)(2) <> '3' then
+    Halt(1);
+end.
+

tests/webtbs/tw40315.pp

@@ -0,0 +1,65 @@
+program tw40315;
+//This program compiles and runs in Delphi and in FPC. (at least should run in FPC)
+//It is intentionally designed this way.
+//It compiles without errors or warnings in Delphi and delivers the expected result.
+
+{$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  TfuncS = reference to function:String;
+      TfuncF = reference to function(s:String):TfuncS;
+var   f_inner: TfuncS;
+      f_outer: TfuncF;
+
+procedure caller;
+begin
+  f_inner();
+end;
+
+procedure main;
+
+var str: String;
+   // f_outer: TfuncF;  // <---- doesnt compile in FPC when this is uncommented, but compiles and runs ok in Delphi
+
+begin
+
+    str := 'Hello World!';
+
+    f_outer := function(s:String):TfuncS //This captures local and persistent copy of "str"
+    begin
+      Result := function:String // <---- Access violation here, when Line "Result:=s" is commented out and when it is compiled.
+      begin
+        Result := s;  // <---- project1.lpr(37,9) Error: Internal error 2011010304
+                      // if the line is commented out it compiles, but gives access violation at runtime
+
+        Writeln(s);
+      end;
+      Writeln('Outer function was called');
+    end;
+    f_inner := f_outer(str);   //This instantiates the outer function and f_inner and captures their local context.
+
+    SetLength(str,0); //Erase the string content
+
+    Writeln('now calling f_inner');
+    caller();  //This line prints the string s="Hello World!", 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 string "str"?');
+  //if f_inner()='Hello World!' then writeln('Yes! :-)') else writeln ('No! :-(');
+  if f_inner()<>'Hello World!' then
+    Halt(1);
+
+  //readln;
+end.