* synchronized with trunk

git-svn-id: branches/wasm@46785 -

.gitattributes

@@ -16166,6 +16166,7 @@ tests/test/units/sysutils/tstrcmp.pp svneol=native#text/plain
 tests/test/units/sysutils/tstrtobool.pp svneol=native#text/plain
 tests/test/units/sysutils/tunifile.pp svneol=native#text/plain
 tests/test/units/sysutils/tuplow.pp svneol=native#text/plain
+tests/test/units/sysutils/tw37374.pp svneol=native#text/plain
 tests/test/units/sysutils/twstralloc.pp svneol=native#text/plain
 tests/test/units/sysutils/twstrcmp.pp svneol=native#text/plain
 tests/test/units/types/ttbitconverter.pp svneol=native#text/pascal

compiler/defcmp.pas

@@ -59,7 +59,8 @@ interface
           cdo_allow_variant,
           cdo_parameter,
           cdo_warn_incompatible_univ,
-          cdo_strict_undefined_check  // undefined defs are incompatible to everything except other undefined defs
+          cdo_strict_undefined_check,  // undefined defs are incompatible to everything except other undefined defs
+          cdo_equal_check              // this call is only to check equality -> shortcut some expensive checks
        );
        tcompare_defs_options = set of tcompare_defs_option;
 
@@ -1703,7 +1704,13 @@ implementation
            objectdef :
              begin
                { object pascal objects }
-               if (def_from.typ=objectdef) and
+               { don't call def_is_related if we came here from equal_defs, because
+                   1) this can never result in an "equal result", and
+                   2) def_is_related itself calls equal_defs again for each class in
+                      the hierarchy, which will call compare_defs_ext, which will again
+                      call def_is_related -> quadratic complexity explosion }
+               if not(cdo_equal_check in cdoptions) and
+                  (def_from.typ=objectdef) and
                   (def_is_related(tobjectdef(def_from),tobjectdef(def_to))) then
                 begin
                   doconv:=tc_equal;
@@ -2001,7 +2008,7 @@ implementation
       begin
         { Compare defs with nothingn and no explicit typecasts and
           searching for overloaded operators is not needed }
-        equal_defs:=(compare_defs_ext(def_from,def_to,nothingn,convtyp,pd,[])>=te_equal);
+        equal_defs:=(compare_defs_ext(def_from,def_to,nothingn,convtyp,pd,[cdo_equal_check])>=te_equal);
       end;
 
 

compiler/ncgrtti.pas

@@ -133,6 +133,9 @@ implementation
                   { Skip forward defs }
                   if (oo_is_forward in tobjectdef(def).objectoptions) then
                     continue;
+                  { skip unique type aliases, they use the RTTI from the parent class }
+                  if tobjectdef(def).is_unique_objpasdef then
+                    continue;
                   write_persistent_type_info(tobjectdef(def).symtable,is_global);
                 end;
               procdef :

compiler/ncgutil.pas

@@ -588,6 +588,34 @@ implementation
 
 
     procedure gen_alloc_regvar(list:TAsmList;sym: tabstractnormalvarsym; allocreg: boolean);
+
+      procedure set_para_regvar_initial_location;
+        var
+          paraloc: PCGParalocation;
+          loc: tlocation;
+          regtype: tregistertype;
+          reg: tregister;
+          size: tcgint;
+        begin
+          tparavarsym(sym).paraloc[calleeside].get_location(loc);
+          size:=tparavarsym(sym).paraloc[calleeside].IntSize;
+          paraloc:=tparavarsym(sym).paraloc[calleeside].Location;
+          reg:=sym.initialloc.register;
+          regtype:=getregtype(reg);
+          repeat
+            loc.reference.offset:=paraloc^.reference.offset;
+            cg.rg[regtype].set_reg_initial_location(reg,loc.reference);
+            dec(size,tcgsize2size[paraloc^.Size]);
+{$if defined(cpu8bitalu) or defined(cpu16bitalu)}
+            if cg.has_next_reg[getsupreg(reg)] then
+              reg:=cg.GetNextReg(reg)
+            else
+{$endif}
+              reg:=sym.initialloc.registerhi;
+            paraloc:=paraloc^.Next;
+          until size=0;
+        end;
+
       var
         usedef: tdef;
         varloc: tai_varloc;
@@ -674,6 +702,11 @@ implementation
 {$endif cpu64bitalu and not cpuhighleveltarget}
           varloc:=tai_varloc.create(sym,sym.initialloc.register);
         list.concat(varloc);
+        { Notify the register allocator about memory location of
+          the register which holds a value of a stack parameter }
+        if (sym.typ=paravarsym) and
+          (tparavarsym(sym).paraloc[calleeside].Location^.Loc=LOC_REFERENCE) then
+          set_para_regvar_initial_location;
       end;
 
 

compiler/ncgvmt.pas

@@ -699,11 +699,16 @@ implementation
 
     function CreateWrapperName(_class : tobjectdef;AImplIntf : TImplementedInterface;i : longint;pd : tprocdef) : string;
       var
+        realintfdef: tobjectdef;
         tmpstr : AnsiString;
         hs : string;
         crc : DWord;
       begin
-        tmpstr:=_class.objname^+'_$_'+AImplIntf.IntfDef.objname^+'_$_'+tostr(i)+'_$_'+pd.mangledname;
+        realintfdef:=AImplIntf.IntfDef;
+        while realintfdef.is_unique_objpasdef do
+          realintfdef:=realintfdef.childof;
+
+        tmpstr:=_class.objname^+'_$_'+realintfdef.objname^+'_$_'+tostr(i)+'_$_'+pd.mangledname;
         if length(tmpstr)>100 then
           begin
             crc:=0;
@@ -749,14 +754,18 @@ implementation
         pd: tprocdef;
         siid,
         siidstr: tsymstr;
+        nonuniqueintf: tobjectdef;
       begin
+        nonuniqueintf:=AImplIntf.IntfDef;
+        while nonuniqueintf.is_unique_objpasdef do
+          nonuniqueintf:=nonuniqueintf.childof;
         tcb.maybe_begin_aggregate(interfaceentrydef);
         { GUID (or nil for Corba interfaces) }
         tcb.next_field:=tabstractrecorddef(interfaceentrydef).symtable.Find('IIDREF') as tfieldvarsym;
         siid:='';
-        if AImplIntf.IntfDef.objecttype in [odt_interfacecom] then
+        if nonuniqueintf.objecttype in [odt_interfacecom] then
           begin
-            siid:=make_mangledname('IID',AImplIntf.IntfDef.owner,AImplIntf.IntfDef.objname^);
+            siid:=make_mangledname('IID',nonuniqueintf.owner,nonuniqueintf.objname^);
             tcb.emit_tai(Tai_const.Create_sym_offset(
               current_asmdata.RefAsmSymbol(siid,AT_DATA,true),0),cpointerdef.getreusable(rec_tguid));
           end
@@ -766,7 +775,7 @@ implementation
         { VTable }
         tcb.next_field:=tabstractrecorddef(interfaceentrydef).symtable.Find('VTABLE') as tfieldvarsym;
         tcb.queue_init(voidpointertype);
-        tcb.queue_emit_asmsym(fintfvtablelabels[intfindex],AImplIntf.VtblImplIntf.IntfDef);
+        tcb.queue_emit_asmsym(fintfvtablelabels[intfindex],nonuniqueintf);
         { IOffset field }
         case AImplIntf.VtblImplIntf.IType of
           etFieldValue, etFieldValueClass,
@@ -792,20 +801,20 @@ implementation
 
         { IIDStr }
         tcb.next_field:=tabstractrecorddef(interfaceentrydef).symtable.Find('IIDSTRREF') as tfieldvarsym;
-        siidstr:=make_mangledname('IIDSTR',AImplIntf.IntfDef.owner,AImplIntf.IntfDef.objname^);
+        siidstr:=make_mangledname('IIDSTR',nonuniqueintf.owner,nonuniqueintf.objname^);
         tcb.queue_init(cpointerdef.getreusable(cshortstringtype));
         tcb.queue_emit_asmsym(
           current_asmdata.RefAsmSymbol(
             siidstr,
             AT_DATA,
             true),
-          cpointerdef.getreusable(carraydef.getreusable(cansichartype,length(AImplIntf.IntfDef.iidstr^)+1)));
+          cpointerdef.getreusable(carraydef.getreusable(cansichartype,length(nonuniqueintf.iidstr^)+1)));
         { IType }
         tcb.next_field:=tabstractrecorddef(interfaceentrydef).symtable.Find('ITYPE') as tfieldvarsym;
         tcb.emit_ord_const(aint(AImplIntf.VtblImplIntf.IType),interfaceentrytypedef);
         tcb.maybe_end_aggregate(interfaceentrydef);
 
-        if findunitsymtable(AImplIntf.IntfDef.owner).moduleid<>findunitsymtable(_Class.owner).moduleid then
+        if findunitsymtable(nonuniqueintf.owner).moduleid<>findunitsymtable(_Class.owner).moduleid then
           begin
             if siid<>'' then
               current_module.add_extern_asmsym(siid,AB_EXTERNAL,AT_DATA);
@@ -1300,6 +1309,8 @@ implementation
                   if ([df_generic,df_genconstraint]*def.defoptions<>[]) or
                      (oo_is_forward in tobjectdef(def).objectoptions) then
                     continue;
+                  if tobjectdef(def).is_unique_objpasdef then
+                    continue;
                   do_write_vmts(tobjectdef(def).symtable,is_global);
                   { Write also VMT if not done yet }
                   if not(ds_vmt_written in def.defstates) then

compiler/pdecl.pas

@@ -674,7 +674,8 @@ implementation
          gentypename,genorgtypename : TIDString;
          newtype  : ttypesym;
          sym      : tsym;
-         hdef     : tdef;
+         hdef,
+         hdef2    : tdef;
          defpos,storetokenpos : tfileposinfo;
          old_block_type : tblock_type;
          old_checkforwarddefs: TFPObjectList;
@@ -927,9 +928,11 @@ implementation
                       if is_object(hdef) or
                          is_class_or_interface_or_dispinterface(hdef) then
                         begin
-                          { just create a child class type; this is
+                          { just create a copy that is a child of the original class class type; this is
                             Delphi-compatible }
-                          hdef:=cobjectdef.create(tobjectdef(hdef).objecttype,genorgtypename,tobjectdef(hdef),true);
+                          hdef2:=tstoreddef(hdef).getcopy;
+                          tobjectdef(hdef2).childof:=tobjectdef(hdef);
+                          hdef:=hdef2;
                         end
                       else
                         begin
@@ -959,6 +962,7 @@ implementation
                              (tabstractpointerdef(hdef).pointeddef.typ=forwarddef) then
                             current_module.checkforwarddefs.add(hdef);
                         end;
+
                       include(hdef.defoptions,df_unique);
                     end;
                   if not assigned(hdef.typesym) then
@@ -1114,7 +1118,7 @@ implementation
                       finalize_class_external_status(tobjectdef(hdef));
 
                     { Build VMT indexes, skip for type renaming and forward classes }
-                    if (hdef.typesym=newtype) and
+                    if not istyperenaming and
                        not(oo_is_forward in tobjectdef(hdef).objectoptions) then
                       build_vmt(tobjectdef(hdef));
 

compiler/rgobj.pas

@@ -93,9 +93,10 @@ unit rgobj;
       end;
 
       Treginfoflag=(
-        ri_coalesced,   { the register is coalesced with other register }
-        ri_selected,    { the register is put to selectstack }
-        ri_spill_read   { the register contains a value loaded from a spilled register }
+        ri_coalesced,       { the register is coalesced with other register }
+        ri_selected,        { the register is put to selectstack }
+        ri_spill_read,      { the register contains a value loaded from a spilled register }
+        ri_has_initial_loc  { the register has the initial memory location (e.g. a parameter in the stack) }
       );
       Treginfoflagset=set of Treginfoflag;
 
@@ -189,6 +190,8 @@ unit rgobj;
         procedure add_edge(u,v:Tsuperregister);
         { translates a single given imaginary register to it's real register }
         procedure translate_register(var reg : tregister);
+        { sets the initial memory location of the register }
+        procedure set_reg_initial_location(reg: tregister; const ref: treference);
       protected
         maxreginfo,
         maxreginfoinc,
@@ -293,6 +296,7 @@ unit rgobj;
         function get_live_start(reg : tsuperregister) : tai;
         procedure set_live_end(reg : tsuperregister;t : tai);
         function get_live_end(reg : tsuperregister) : tai;
+        procedure alloc_spillinfo(max_reg: Tsuperregister);
 {$ifdef DEBUG_SPILLCOALESCE}
         procedure write_spill_stats;
 {$endif DEBUG_SPILLCOALESCE}
@@ -637,10 +641,18 @@ unit rgobj;
           i8086 where indexed memory access instructions allow only
           few registers as arguments and additionally the calling convention
           provides no general purpose volatile registers.
+          
+          Also spill registers which have the initial memory location
+          and are used only once. This allows to access the memory location
+          directly, without preloading it to a register.
         }
         for i:=first_imaginary to maxreg-1 do
-          if reginfo[i].real_reg_interferences>=usable_registers_cnt then
-            spillednodes.add(i);
+          with reginfo[i] do
+            if (real_reg_interferences>=usable_registers_cnt) or
+               { also spill registers which have the initial memory location
+                 and are used only once }
+               ((ri_has_initial_loc in flags) and (weight<=200)) then
+              spillednodes.add(i);
         if spillednodes.length<>0 then
           begin
             spill_registers(list,headertai);
@@ -859,6 +871,19 @@ unit rgobj;
       end;
 
 
+    procedure trgobj.alloc_spillinfo(max_reg: Tsuperregister);
+      var
+        j: longint;
+      begin
+        if Length(spillinfo)<max_reg then
+          begin
+            j:=Length(spillinfo);
+            SetLength(spillinfo,max_reg);
+            fillchar(spillinfo[j],sizeof(spillinfo[0])*(Length(spillinfo)-j),0);
+          end;
+      end;
+
+
     procedure trgobj.add_reg_instruction(instr:Tai;r:tregister;aweight:longint);
       var
         supreg : tsuperregister;
@@ -2106,7 +2131,20 @@ unit rgobj;
       end;
 
 
-    procedure Trgobj.translate_registers(list:TAsmList);
+    procedure trgobj.set_reg_initial_location(reg: tregister; const ref: treference);
+      var
+        supreg: TSuperRegister;
+      begin
+        supreg:=getsupreg(reg);
+        if supreg>=maxreg then
+          internalerror(2020090501);
+        alloc_spillinfo(supreg+1);
+        spillinfo[supreg].spilllocation:=ref;
+        include(reginfo[supreg].flags,ri_has_initial_loc);
+      end;
+
+
+    procedure trgobj.translate_registers(list: TAsmList);
 
       function get_reg_name_full(r: tregister): string;
         var
@@ -2332,13 +2370,7 @@ unit rgobj;
         writeln('trgobj.spill_registers: Spilling ',spillednodes.length,' nodes');
 {$endif DEBUG_SPILLCOALESCE}
         { after each round of spilling, more registers could be used due to allocations for spilling }
-        if Length(spillinfo)<maxreg then
-          begin
-            j:=Length(spillinfo);
-            SetLength(spillinfo,maxreg);
-            fillchar(spillinfo[j],sizeof(spillinfo[0])*(Length(spillinfo)-j),0);
-          end;
-
+        alloc_spillinfo(maxreg);
         { Allocate temps and insert in front of the list }
         templist:=TAsmList.create;
         { Safe: this procedure is only called if there are spilled nodes. }
@@ -2363,13 +2395,17 @@ unit rgobj;
               { Clear all interferences of the spilled register. }
               clear_interferences(t);
 
-              getnewspillloc:=true;
+              getnewspillloc:=not (ri_has_initial_loc in reginfo[t].flags);
+              if not getnewspillloc then
+                spill_temps^[t]:=spillinfo[t].spilllocation;
 
               { check if we can "coalesce" spilled nodes. To do so, it is required that they do not
                 interfere but are connected by a move instruction
 
                 doing so might save some mem->mem moves }
-              if (cs_opt_level3 in current_settings.optimizerswitches) and assigned(reginfo[t].movelist) then
+              if (cs_opt_level3 in current_settings.optimizerswitches) and
+                 getnewspillloc and
+                 assigned(reginfo[t].movelist) then
                 for j:=0 to reginfo[t].movelist^.header.count-1 do
                   begin
                     x:=Tmoveins(reginfo[t].movelist^.data[j]).x;
@@ -2427,6 +2463,17 @@ unit rgobj;
                         supreg:=getsupreg(reg);
                         if supregset_in(regs_to_spill_set,supreg) then
                           begin
+                            { Remove loading of the register from its initial memory location
+                              (e.g. load of a stack parameter to the register). }
+                            if (ratype=ra_alloc) and
+                               (ri_has_initial_loc in reginfo[supreg].flags) and
+                               (instr<>nil) then
+                              begin
+                                list.remove(instr);
+                                FreeAndNil(instr);
+                                dec(reginfo[supreg].weight,100);
+                              end;
+                            { Remove the regalloc }
                             q:=Tai(p.next);
                             list.remove(p);
                             p.free;
@@ -2466,7 +2513,7 @@ unit rgobj;
         {Safe: this procedure is only called if there are spilled nodes.}
         with spillednodes do
           for i:=0 to length-1 do
-            tg.ungettemp(list,spill_temps^[buf^[i]]);
+            tg.ungetiftemp(list,spill_temps^[buf^[i]]);
         freemem(spill_temps);
       end;
 
@@ -2872,7 +2919,7 @@ unit rgobj;
         all_weight,spill_weight,d: double;
       begin
         max_weight:=1;
-        for i:=0 to high(spillinfo) do
+        for i:=first_imaginary to maxreg-1 do
           with reginfo[i] do
             if weight>max_weight then
               max_weight:=weight;
@@ -2880,12 +2927,14 @@ unit rgobj;
         spillingcounter:=0;
         spill_weight:=0;
         all_weight:=0;
-        for i:=0 to high(spillinfo) do
+        for i:=first_imaginary to maxreg-1 do
           with reginfo[i] do
             begin
-              d:=weight/max_weight*count_uses;
+              d:=weight/max_weight;
               all_weight:=all_weight+d;
-              if spillinfo[i].spilled then
+              if (weight>100) and
+                 (i<=high(spillinfo)) and
+                 spillinfo[i].spilled then
                 begin
                   inc(spillingcounter);
                   spill_weight:=spill_weight+d;

compiler/symdef.pas

@@ -511,6 +511,7 @@ interface
           function  needs_separate_initrtti : boolean;override;
           function  has_non_trivial_init_child(check_parent:boolean):boolean;override;
           function  rtti_mangledname(rt:trttitype):TSymStr;override;
+          function  is_unique_objpasdef: boolean;
           function  vmt_mangledname : TSymStr;
           function  vmt_def: trecorddef;
           procedure check_forwards; override;
@@ -3900,6 +3901,8 @@ implementation
 
     constructor tclassrefdef.create(def:tdef);
       begin
+         while tobjectdef(def).is_unique_objpasdef do
+           def:=tobjectdef(def).childof;
          inherited create(classrefdef,def);
          if df_specialization in tstoreddef(def).defoptions then
            genericdef:=cclassrefdef.create(tstoreddef(def).genericdef);
@@ -7890,7 +7893,10 @@ implementation
       begin
         if not(oo_has_vmt in objectoptions) then
           Message1(parser_n_object_has_no_vmt,objrealname^);
-        vmt_mangledname:=make_mangledname('VMT',owner,objname^);
+        if not is_unique_objpasdef then
+          vmt_mangledname:=make_mangledname('VMT',owner,objname^)
+        else
+          vmt_mangledname:=childof.vmt_mangledname;
       end;
 
 
@@ -7899,13 +7905,18 @@ implementation
         where: tsymtable;
         vmttypesym: tsymentry;
       begin
-        where:=get_top_level_symtable(true);
-        vmttypesym:=where.Find('vmtdef$'+mangledparaname);
-        if not assigned(vmttypesym) or
-           (vmttypesym.typ<>symconst.typesym) or
-           (ttypesym(vmttypesym).typedef.typ<>recorddef) then
-          internalerror(2015052501);
-        result:=trecorddef(ttypesym(vmttypesym).typedef);
+        if not is_unique_objpasdef then
+          begin
+            where:=get_top_level_symtable(true);
+            vmttypesym:=where.Find('vmtdef$'+mangledparaname);
+            if not assigned(vmttypesym) or
+               (vmttypesym.typ<>symconst.typesym) or
+               (ttypesym(vmttypesym).typedef.typ<>recorddef) then
+              internalerror(2015052501);
+            result:=trecorddef(ttypesym(vmttypesym).typedef);
+          end
+        else
+          result:=childof.vmt_def;
       end;
 
 
@@ -7971,7 +7982,12 @@ implementation
     function tobjectdef.rtti_mangledname(rt: trttitype): TSymStr;
       begin
         if not(objecttype in [odt_objcclass,odt_objcprotocol]) then
-          result:=inherited rtti_mangledname(rt)
+          begin
+            if not is_unique_objpasdef then
+              result:=inherited rtti_mangledname(rt)
+            else
+              result:=childof.rtti_mangledname(rt)
+          end
         else
           begin
             { necessary in case of a dynamic array of nsobject, or
@@ -8054,6 +8070,13 @@ implementation
           end;
       end;
 
+    function tobjectdef.is_unique_objpasdef: boolean;
+        begin
+          result:=
+            (df_unique in defoptions) and
+            is_class_or_interface_or_dispinterface(self)
+        end;
+
 
     function tobjectdef.members_need_inittable : boolean;
       begin

compiler/symtable.pas

@@ -3607,6 +3607,10 @@ implementation
         formalnameptr,
         foundnameptr: pshortstring;
       begin
+        while pd.is_unique_objpasdef do
+          begin
+            pd:=pd.childof;
+          end;
         { not a formal definition -> return it }
         if not(oo_is_formal in pd.objectoptions) then
           begin

compiler/systems/t_freertos.pas

@@ -96,10 +96,10 @@ begin
   prtobj:='';
 {$else}
   prtobj:='prt0';
-{$endif}
   cprtobj:='cprt0';
   if linklibc then
     prtobj:=cprtobj;
+{$endif}
 
   { Open link.res file }
   LinkRes:=TLinkRes.Create(outputexedir+Info.ResName,true);
@@ -132,14 +132,18 @@ begin
       LinkRes.AddFileName(s);
     end;
 
-  { try to add crti and crtbegin if linking to C }
-  if linklibc then
-   begin
-     if librarysearchpath.FindFile('crtbegin.o',false,s) then
-      LinkRes.AddFileName(s);
-     if librarysearchpath.FindFile('crti.o',false,s) then
-      LinkRes.AddFileName(s);
-   end;
+  { xtensa FreeRTOS links always against libc, the runtime needs it }
+  if not(target_info.system in [system_xtensa_freertos]) then
+    begin
+      { try to add crti and crtbegin if linking to C }
+      if linklibc then
+       begin
+         if librarysearchpath.FindFile('crtbegin.o',false,s) then
+          LinkRes.AddFileName(s);
+         if librarysearchpath.FindFile('crti.o',false,s) then
+          LinkRes.AddFileName(s);
+       end;
+    end;
 
   while not ObjectFiles.Empty do
    begin
@@ -165,50 +169,58 @@ begin
         end;
     end;
 
-   LinkRes.Add(')');
-
-   { Write sharedlibraries like -l<lib>, also add the needed dynamic linker
-     here to be sure that it gets linked this is needed for glibc2 systems (PFV) }
-   linklibc:=false;
-   while not SharedLibFiles.Empty do
+  { xtensa FreeRTOS links always against libc, the runtime needs it }
+  if not(target_info.system in [system_xtensa_freertos]) then
     begin
-     S:=SharedLibFiles.GetFirst;
-     if s<>'c' then
+     { Write sharedlibraries like -l<lib>, also add the needed dynamic linker
+       here to be sure that it gets linked this is needed for glibc2 systems (PFV) }
+     linklibc:=false;
+     while not SharedLibFiles.Empty do
       begin
-       i:=Pos(target_info.sharedlibext,S);
-       if i>0 then
-        Delete(S,i,255);
-       LinkRes.Add('-l'+s);
-      end
-     else
+       S:=SharedLibFiles.GetFirst;
+       if s<>'c' then
+        begin
+         i:=Pos(target_info.sharedlibext,S);
+         if i>0 then
+          Delete(S,i,255);
+         LinkRes.Add('-l'+s);
+        end
+       else
+        begin
+         LinkRes.Add('-l'+s);
+         linklibc:=true;
+        end;
+      end;
+     { be sure that libc&libgcc is the last lib }
+     if linklibc then
       begin
-       LinkRes.Add('-l'+s);
-       linklibc:=true;
+       LinkRes.Add('-lc');
+       LinkRes.Add('-lgcc');
       end;
     end;
-   { be sure that libc&libgcc is the last lib }
-   if linklibc then
+
+  LinkRes.Add(')');
+
+  { xtensa FreeRTOS links always against libc }
+  if not(target_info.system in [system_xtensa_freertos]) then
     begin
-     LinkRes.Add('-lc');
-     LinkRes.Add('-lgcc');
+      { objects which must be at the end }
+      if linklibc then
+       begin
+         found1:=librarysearchpath.FindFile('crtend.o',false,s1);
+         found2:=librarysearchpath.FindFile('crtn.o',false,s2);
+         if found1 or found2 then
+          begin
+            LinkRes.Add('INPUT(');
+            if found1 then
+             LinkRes.AddFileName(s1);
+            if found2 then
+             LinkRes.AddFileName(s2);
+            LinkRes.Add(')');
+          end;
+       end;
     end;
 
-  { objects which must be at the end }
-  if linklibc then
-   begin
-     found1:=librarysearchpath.FindFile('crtend.o',false,s1);
-     found2:=librarysearchpath.FindFile('crtn.o',false,s2);
-     if found1 or found2 then
-      begin
-        LinkRes.Add('INPUT(');
-        if found1 then
-         LinkRes.AddFileName(s1);
-        if found2 then
-         LinkRes.AddFileName(s2);
-        LinkRes.Add(')');
-      end;
-   end;
-
 {$ifdef ARM}
   with embedded_controllers[current_settings.controllertype] do
     with linkres do

compiler/xtensa/cgcpu.pas

@@ -286,7 +286,8 @@ implementation
           (href.index<>NR_NO) or
           ((op=A_L8UI) and ((href.offset<0) or (href.offset>255))) or
           ((op in [A_L16SI,A_L16UI]) and ((href.offset<0) or (href.offset>510) or (href.offset mod 2<>0))) or
-          ((op=A_L32I) and ((href.offset<0) or (href.offset>1020) or (href.offset mod 4<>0))) then
+          ((op=A_L32I) and ((href.offset<0) or (href.offset>1020) or (href.offset mod 4<>0))) or
+          ((href.base=NR_NO) and (href.index=NR_NO)) then
           fixref(list,href);
 
         list.concat(taicpu.op_reg_ref(op,reg,href));
@@ -329,15 +330,21 @@ implementation
         l : tasmlabel;
       begin
         { create consts entry }
-        if assigned(ref.symbol) or (ref.offset<-2048) or (ref.offset>2047) then
+        if assigned(ref.symbol) or (ref.offset<-2048) or (ref.offset>2047) or
+          ((ref.base=NR_NO) and (ref.index=NR_NO)) then
           begin
             reference_reset(tmpref,4,[]);
             tmpreg:=NR_NO;
 
             { load consts entry }
             tmpreg:=getintregister(list,OS_INT);
-            tmpref.symbol:=create_data_entry(ref.symbol,ref.offset);
-            list.concat(taicpu.op_reg_ref(A_L32R,tmpreg,tmpref));
+            if ref.symbol=nil then
+              a_load_const_reg(list,OS_ADDR,ref.offset,tmpreg)
+            else
+              begin
+                tmpref.symbol:=create_data_entry(ref.symbol,ref.offset);
+                list.concat(taicpu.op_reg_ref(A_L32R,tmpreg,tmpref));
+              end;
 
             if ref.base<>NR_NO then
               begin
@@ -1053,15 +1060,28 @@ implementation
             tmpreg1  := GetIntRegister(list, OS_INT);
             a_load_const_reg(list, OS_INT, Count, countreg);
             current_asmdata.getjumplabel(lab);
-            a_label(list, lab);
-            list.concat(taicpu.op_reg_ref(A_L32I, tmpreg1, src));
-            list.concat(taicpu.op_reg_ref(A_S32I, tmpreg1, dst));
-            list.concat(taicpu.op_reg_reg_const(A_ADDI, src.base, src.base, 4));
-            list.concat(taicpu.op_reg_reg_const(A_ADDI, dst.base, dst.base, 4));
-            list.concat(taicpu.op_reg_reg_const(A_ADDI, countreg, countreg, -1));
-            a_cmp_const_reg_label(list,OS_INT,OC_GT,0,countreg,lab);
+            if CPUXTENSA_HAS_LOOPS in cpu_capabilities[current_settings.cputype] then
+              begin
+                list.concat(taicpu.op_reg_sym(A_LOOP, countreg, lab));
+                list.concat(taicpu.op_reg_ref(A_L32I, tmpreg1, src));
+                list.concat(taicpu.op_reg_ref(A_S32I, tmpreg1, dst));
+                list.concat(taicpu.op_reg_reg_const(A_ADDI, src.base, src.base, 4));
+                list.concat(taicpu.op_reg_reg_const(A_ADDI, dst.base, dst.base, 4));
+                a_label(list, lab);
+              end
+            else
+              begin
+                a_label(list, lab);
+                list.concat(taicpu.op_reg_ref(A_L32I, tmpreg1, src));
+                list.concat(taicpu.op_reg_ref(A_S32I, tmpreg1, dst));
+                list.concat(taicpu.op_reg_reg_const(A_ADDI, src.base, src.base, 4));
+                list.concat(taicpu.op_reg_reg_const(A_ADDI, dst.base, dst.base, 4));
+                list.concat(taicpu.op_reg_reg_const(A_ADDI, countreg, countreg, -1));
+                a_cmp_const_reg_label(list,OS_INT,OC_NE,0,countreg,lab);
+                { keep the registers alive }
+                list.concat(taicpu.op_reg_reg(A_MOV,countreg,countreg));
+              end;
             { keep the registers alive }
-            list.concat(taicpu.op_reg_reg(A_MOV,countreg,countreg));
             list.concat(taicpu.op_reg_reg(A_MOV,src.base,src.base));
             list.concat(taicpu.op_reg_reg(A_MOV,dst.base,dst.base));
             len := len mod 4;

compiler/xtensa/cpuinfo.pas

@@ -139,7 +139,8 @@ Const
         CPUXTENSA_HAS_SEXT,
         CPUXTENSA_HAS_BOOLEAN_OPTION,
         CPUXTENSA_HAS_MUL32HIGH,
-        CPUXTENSA_HAS_DIV
+        CPUXTENSA_HAS_DIV,
+        CPUXTENSA_HAS_LOOPS
       );
 
    tfpuflags =
@@ -153,7 +154,7 @@ Const
      (
        { cpu_none     } [],
        { cpu_lx106    } [],
-       { cpu_lx6      } [CPUXTENSA_REGWINDOW, CPUXTENSA_HAS_SEXT, CPUXTENSA_HAS_BOOLEAN_OPTION, CPUXTENSA_HAS_MUL32HIGH, CPUXTENSA_HAS_DIV]
+       { cpu_lx6      } [CPUXTENSA_REGWINDOW, CPUXTENSA_HAS_SEXT, CPUXTENSA_HAS_BOOLEAN_OPTION, CPUXTENSA_HAS_MUL32HIGH, CPUXTENSA_HAS_DIV, CPUXTENSA_HAS_LOOPS]
      );
 
    fpu_capabilities : array[tfputype] of set of tfpuflags =

compiler/xtensa/cpupara.pas

@@ -80,61 +80,28 @@ unit cpupara;
 
 
     function getparaloc(p : tdef) : tcgloc;
-
       begin
-         { Later, the LOC_REFERENCE is in most cases changed into LOC_REGISTER
-           if push_addr_param for the def is true
-         }
-         case p.typ of
-            orddef:
-              result:=LOC_REGISTER;
-            floatdef:
-              result:=LOC_REGISTER;
-            enumdef:
-              result:=LOC_REGISTER;
-            pointerdef:
-              result:=LOC_REGISTER;
-            formaldef:
-              result:=LOC_REGISTER;
-            classrefdef:
-              result:=LOC_REGISTER;
-            procvardef:
-              result:=LOC_REGISTER;
-            recorddef:
-              if p.size>24 then
-                result:=LOC_REFERENCE
-              else
-                result:=LOC_REGISTER;
-            objectdef:
-              if is_object(p) and (p.size>24) then
-                result:=LOC_REFERENCE
-              else
-                result:=LOC_REGISTER;
-            stringdef:
-              if is_shortstring(p) or is_longstring(p) then
-                result:=LOC_REFERENCE
-              else
-                result:=LOC_REGISTER;
-            filedef:
-              result:=LOC_REGISTER;
-            arraydef:
-              if is_dynamic_array(p) or (p.size<=24) then
-                getparaloc:=LOC_REGISTER
-              else
-                result:=LOC_REFERENCE;
-            setdef:
-              if is_smallset(p) then
-                result:=LOC_REGISTER
-              else
-                result:=LOC_REFERENCE;
-            variantdef:
-              result:=LOC_REGISTER;
-            { avoid problems with errornous definitions }
-            errordef:
-              result:=LOC_REGISTER;
-            else
-              internalerror(2020082501);
-         end;
+        case p.typ of
+          orddef,
+          floatdef,
+          enumdef,
+          pointerdef,
+          formaldef,
+          classrefdef,
+          procvardef,
+          recorddef,
+          objectdef,
+          stringdef,
+          filedef,
+          arraydef,
+          setdef,
+          variantdef,
+          { avoid problems with errornous definitions }
+          errordef:
+            result:=LOC_REGISTER;
+          else
+            internalerror(2020082501);
+        end;
       end;
 
 
@@ -379,7 +346,7 @@ unit cpupara;
 
         locpara:=getparaloc(paradef);
 
-        if (locpara=LOC_REGISTER) and ((maxintreg-curintreg+1)*4<paradef.size) then
+        if (maxintreg-curintreg+1)*4<paralen then
           begin
             locpara:=LOC_REFERENCE;
             curintreg:=maxintreg+1;
@@ -389,7 +356,7 @@ unit cpupara;
         loc.size:=paracgsize;
         loc.intsize:=paralen;
         loc.def:=paradef;
-        if (locpara=LOC_REGISTER) and (is_64bit(paradef)) and
+        if (locpara=LOC_REGISTER) and (paradef.alignment>4) and
            odd(curintreg-RS_A2) then
           inc(curintreg);
         if (paralen = 0) then
@@ -455,6 +422,7 @@ unit cpupara;
                  else
                    paraloc^.reference.index:=current_procinfo.framepointer;
 
+                 cur_stack_offset:=align(cur_stack_offset,paradef.alignment);
                  paraloc^.reference.offset:=cur_stack_offset;
 
                  inc(cur_stack_offset,align(paralen,4));

compiler/xtensa/ncpumat.pas

@@ -236,7 +236,10 @@ implementation
               OS_32:
                 cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_XOR,OS_32,tcgint($80000000),left.location.register,location.register);
               OS_64:
-                cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_XOR,OS_32,tcgint($80000000),left.location.registerhi,location.registerhi);
+                begin
+                  cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_XOR,OS_32,tcgint($80000000),left.location.registerhi,location.registerhi);
+                  cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_32,OS_32,left.location.register64.reglo,location.register64.reglo);
+                end;
             else
               internalerror(2014033101);
             end;

packages/pastojs/src/fppas2js.pp

@@ -1516,7 +1516,7 @@ type
       override;
     procedure SpecializeGenericImpl(SpecializedItem: TPRSpecializedItem);
       override;
-    function SpecializeNeedsDelay(SpecializedItem: TPRSpecializedItem): TPasElement; virtual;
+    function SpecializeParamsNeedDelay(SpecializedItem: TPRSpecializedItem): TPasElement; virtual;
     function CreateLongName(SpecializedItem: TPRSpecializedItem): string; virtual;
   protected
     const
@@ -1909,6 +1909,7 @@ type
     Procedure FindAvailableLocalName(var aName: string; JSExpr: TJSElement);
     Function GetImplJSProcScope(El: TPasElement; Src: TJSSourceElements;
       AContext: TConvertContext): TPas2JSProcedureScope;
+    Function SpecializeNeedsDelay(El: TPasGenericType; AContext: TConvertContext): boolean; virtual;
     // Never create an element manually, always use the below functions
     Function CreateElement(C: TJSElementClass; Src: TPasElement): TJSElement; virtual;
     Function CreateFreeOrNewInstanceExpr(Ref: TResolvedReference;
@@ -5027,7 +5028,7 @@ begin
 
   El:=SpecializedItem.SpecializedEl;
   if (El is TPasGenericType)
-      and (SpecializeNeedsDelay(SpecializedItem)<>nil) then
+      and (SpecializeParamsNeedDelay(SpecializedItem)<>nil) then
     TPas2JSResolverHub(Hub).AddJSDelaySpecialize(TPasGenericType(El));
 
   if El is TPasMembersType then
@@ -5044,7 +5045,7 @@ begin
     end;
 end;
 
-function TPas2JSResolver.SpecializeNeedsDelay(
+function TPas2JSResolver.SpecializeParamsNeedDelay(
   SpecializedItem: TPRSpecializedItem): TPasElement;
 // finds first specialize param defined later than the generic
 // For example: generic in the unit interface, param in implementation
@@ -14729,7 +14730,7 @@ var
   C: TClass;
   AssignSt: TJSSimpleAssignStatement;
   NeedInitFunction, HasConstructor, IsJSFunction, NeedClassExt,
-    SpecializeNeedsDelay: Boolean;
+    SpecializeDelay: Boolean;
   Proc: TPasProcedure;
 begin
   Result:=nil;
@@ -14760,14 +14761,14 @@ begin
       end;
     FreeAndNil(Scope.MsgIntToProc);
     FreeAndNil(Scope.MsgStrToProc);
-    SpecializeNeedsDelay:=aResolver.SpecializeNeedsDelay(Scope.SpecializedFromItem)<>nil;
+    SpecializeDelay:=SpecializeNeedsDelay(El,AContext);
     end
   else
     begin
     Scope:=nil;
     IsTObject:=(El.AncestorType=nil) and (El.ObjKind=okClass) and SameText(El.Name,'TObject');
     Ancestor:=El.AncestorType;
-    SpecializeNeedsDelay:=false;
+    SpecializeDelay:=false;
     end;
 
   // create call 'rtl.createClass(' or 'rtl.createInterface('
@@ -14874,7 +14875,7 @@ begin
         end;
 
       // add class members: types and class vars
-      if SpecializeNeedsDelay then
+      if SpecializeDelay then
         DelayFuncContext:=CreateDelayedInitFunction(El,Src,FuncContext,DelaySrc);
       if El.ObjKind in ([okClass]+okAllHelpers) then
         begin
@@ -14912,7 +14913,7 @@ begin
             RaiseNotSupported(P,FuncContext,20161221233338);
           if NewEl<>nil then
             begin
-            if SpecializeNeedsDelay and not (P is TPasProcedure) then
+            if SpecializeDelay and not (P is TPasProcedure) then
               AddToSourceElements(DelaySrc,NewEl)
             else
               AddToSourceElements(Src,NewEl);
@@ -14980,7 +14981,7 @@ begin
         AddClassMessageIds(El,Src,FuncContext,pbivnMessageInt);
         AddClassMessageIds(El,Src,FuncContext,pbivnMessageStr);
         // add RTTI init function
-        if SpecializeNeedsDelay then
+        if SpecializeDelay then
           AddClassRTTI(El,DelaySrc,DelayFuncContext)
         else
           AddClassRTTI(El,Src,FuncContext);
@@ -15478,7 +15479,7 @@ var
   Prop: TJSObjectLiteralElement;
   aResolver: TPas2JSResolver;
   Scope: TPas2JSProcTypeScope;
-  SpecializeNeedsDelay: Boolean;
+  SpecializeDelay: Boolean;
   FuncSt: TJSFunctionDeclarationStatement;
   AssignSt: TJSSimpleAssignStatement;
 begin
@@ -15498,8 +15499,7 @@ begin
     RaiseNotSupported(El,AContext,20181231112029);
 
   Scope:=El.CustomData as TPas2JSProcTypeScope;
-  SpecializeNeedsDelay:=(Scope<>nil)
-           and (aResolver.SpecializeNeedsDelay(Scope.SpecializedFromItem)<>nil);
+  SpecializeDelay:=(Scope<>nil) and SpecializeNeedsDelay(El,AContext);
 
   // module.$rtti.$ProcVar("name",function(){})
   if El.IsReferenceTo then
@@ -15514,7 +15514,7 @@ begin
     Prop:=Obj.Elements.AddElement;
     InnerCall:=CreateCallExpression(El);
 
-    if SpecializeNeedsDelay then
+    if SpecializeDelay then
       begin
       Prop.Name:=TJSString(GetBIName(pbivnRTTIProc_InitSpec));
       // init: function(){ this.procsig = rtl.newTIProcSignature(...) }
@@ -15610,7 +15610,7 @@ var
 var
   aResolver: TPas2JSResolver;
   Scope: TPas2JSArrayScope;
-  SpecializeNeedsDelay: Boolean;
+  SpecializeDelay: Boolean;
   AssignSt: TJSSimpleAssignStatement;
   CallName, ArrName: String;
   Obj: TJSObjectLiteral;
@@ -15644,8 +15644,7 @@ begin
   {$ENDIF}
 
   Scope:=El.CustomData as TPas2JSArrayScope;
-  SpecializeNeedsDelay:=(Scope<>nil)
-           and (aResolver.SpecializeNeedsDelay(Scope.SpecializedFromItem)<>nil);
+  SpecializeDelay:=(Scope<>nil) and (SpecializeNeedsDelay(El,AContext));
 
   ProcScope:=nil;
   Src:=nil;
@@ -15793,7 +15792,7 @@ begin
         until false;
         end;
       // eltype: ref
-      if not SpecializeNeedsDelay then
+      if not SpecializeDelay then
         begin
         Prop:=Obj.Elements.AddElement;
         Prop.Name:=TJSString(GetBIName(pbivnRTTIArray_ElType));
@@ -16823,6 +16822,7 @@ var
   aResolver: TPas2JSResolver;
 begin
   if not IsElementUsed(El) then exit;
+  if not SpecializeNeedsDelay(El,AContext) then exit;
   C:=El.ClassType;
   if (C=TPasRecordType)
       or (C=TPasClassType) then
@@ -22495,6 +22495,84 @@ begin
   Result:=AContext.Resolver.GetTopLvlProcScope(El);
 end;
 
+function TPasToJSConverter.SpecializeNeedsDelay(El: TPasGenericType;
+  AContext: TConvertContext): boolean;
+var
+  SpecItem: TPRSpecializedItem;
+  C: TClass;
+  Members: TFPList;
+  ChildEl: TPasElement;
+  PasVar: TPasVariable;
+  aResolver: TPas2JSResolver;
+  PasVarType: TPasType;
+  IsRecord, NeedInitFunction: Boolean;
+  aClass: TPasClassType;
+  ClassScope: TPas2JSClassScope;
+  IntfKind: String;
+  i: Integer;
+begin
+  Result:=false;
+  aResolver:=AContext.Resolver;
+  if aResolver=nil then exit;
+  if not (El.CustomData is TPasGenericScope) then exit;
+  SpecItem:=TPasGenericScope(El.CustomData).SpecializedFromItem;
+  if aResolver.SpecializeParamsNeedDelay(SpecItem)=nil then
+    exit; // params are declared in front of generic -> no need to delay
+
+  if HasTypeInfo(El,AContext) then
+    exit(true); // RTTI -> delay needed
+
+  C:=El.ClassType;
+  if El.InheritsFrom(TPasMembersType) then
+    begin
+    IsRecord:=C=TPasRecordType;
+
+    if C=TPasClassType then
+      begin
+      aClass:=TPasClassType(El);
+      ClassScope:=TPas2JSClassScope(El.CustomData);
+      if aClass.ObjKind=okInterface then
+        begin
+        IntfKind:='';
+        if (ClassScope.AncestorScope=nil) and (not (coNoTypeInfo in Options)) then
+          case aClass.InterfaceType of
+          citCom: IntfKind:='com';
+          citCorba: ; // default
+          else
+            RaiseNotSupported(El,AContext,20200905132130);
+          end;
+        NeedInitFunction:=(pcsfPublished in ClassScope.Flags) or (IntfKind<>'');
+        if not NeedInitFunction then
+          exit; // interface without init function -> no need to delay
+        end;
+      end;
+
+    Members:=TPasMembersType(El).Members;
+    for i:=0 to Members.Count-1 do
+      begin
+      ChildEl:=TPasElement(Members[i]);
+      if not IsElementUsed(ChildEl) then continue;
+      if ChildEl is TPasVariable then
+        begin
+        PasVar:=TPasVariable(ChildEl);
+        if ChildEl.ClassType=TPasConst then
+        else if ChildEl.ClassType=TPasVariable then
+          begin
+          if (not IsRecord) and (PasVar.VarModifiers*[vmClass, vmStatic]=[]) then
+            continue; // class field -> no delay needed
+          end
+        else
+          continue;
+        PasVarType:=aResolver.ResolveAliasType(PasVar.VarType);
+        if (PasVarType.ClassType=TPasRecordType) then
+          exit(true) // global record -> needs delay (Eventually: check if it uses one of the after params)
+        else if (PasVarType.ClassType=TPasArrayType) and (length(TPasArrayType(PasVarType).Ranges)>0) then
+          exit(true); // global static array -> needs delay (Eventually: check if it uses one of the after params)
+        end;
+      end;
+    end;
+end;
+
 function TPasToJSConverter.CreateUnary(Members: array of string; E: TJSElement): TJSUnary;
 var
   unary: TJSUnary;
@@ -24986,7 +25064,6 @@ function TPasToJSConverter.ConvertRecordType(El: TPasRecordType;
   AContext: TConvertContext): TJSElement;
 var
   aResolver: TPas2JSResolver;
-  RecScope: TPas2JSRecordScope;
   DelaySrc: TJSSourceElements;
   DelayFuncContext: TFunctionContext;
   Call: TJSCallExpression;
@@ -25001,7 +25078,7 @@ var
   PasVar: TPasVariable;
   PasVarType: TPasType;
   NewFields, Vars, Methods: TFPList;
-  ok, IsComplex, SpecializeNeedsDelay: Boolean;
+  ok, IsComplex, SpecializeDelay: Boolean;
   VarSt: TJSVariableStatement;
 begin
   Result:=nil;
@@ -25020,8 +25097,7 @@ begin
   DelayFuncContext:=nil;
   ok:=false;
   try
-    RecScope:=TPas2JSRecordScope(El.CustomData);
-    SpecializeNeedsDelay:=aResolver.SpecializeNeedsDelay(RecScope.SpecializedFromItem)<>nil;
+    SpecializeDelay:=SpecializeNeedsDelay(El,AContext);
 
     // rtl.recNewT()
     Call:=CreateCallExpression(El);
@@ -25076,7 +25152,7 @@ begin
     Vars:=TFPList.Create;
     Methods:=TFPList.Create;
     IsComplex:=false;
-    if SpecializeNeedsDelay then
+    if SpecializeDelay then
       DelayFuncContext:=CreateDelayedInitFunction(El,Src,FuncContext,DelaySrc);
     for i:=0 to El.Members.Count-1 do
       begin
@@ -25088,7 +25164,7 @@ begin
       if C=TPasVariable then
         begin
         PasVar:=TPasVariable(P);
-        if ClassVarModifiersType*PasVar.VarModifiers*[vmClass, vmStatic]<>[] then
+        if PasVar.VarModifiers*[vmClass, vmStatic]<>[] then
           IsComplex:=true
         else if aResolver<>nil then
           begin
@@ -25151,7 +25227,7 @@ begin
         RaiseNotSupported(P,FuncContext,20190105105436);
       if NewEl<>nil then
         begin
-        if SpecializeNeedsDelay and not (P is TPasProcedure) then
+        if SpecializeDelay and not (P is TPasProcedure) then
           AddToSourceElements(DelaySrc,NewEl)
         else
           AddToSourceElements(Src,NewEl);
@@ -25178,7 +25254,7 @@ begin
     // add RTTI init function
     if (aResolver<>nil) and HasTypeInfo(El,FuncContext) then
       begin
-      if SpecializeNeedsDelay then
+      if SpecializeDelay then
         CreateRecordRTTI(El,DelaySrc,DelayFuncContext)
       else
         CreateRecordRTTI(El,Src,FuncContext);

rtl/objpas/sysutils/fmtflt.inc

@@ -298,11 +298,13 @@ var
   Function FormatExponent(ASign: FChar; aExponent: Integer) : FString;
 
   begin
-    Result:=IntToStr(aExponent);
+    if E = 0 then
+      aExponent := 0;
+    Result:=IntToStr(Abs(aExponent));
     Result:=StringOfChar('0',ExpSize-Length(Result))+Result;
     if (aExponent<0) then
       Result:='-'+Result
-    else if (aExponent>0) and (aSign='+') then
+    else if (aExponent>=0) and (aSign='+') then
       Result:=aSign+Result;
   end;
 
@@ -383,7 +385,12 @@ begin
                 Inc(I);
               end;
             end;
-          end;  
+          end
+        else if I< SectionLength Then
+          begin
+          inc(I);
+          ToResult(Section[i]);
+          end;
         end;
       else
         ToResult(C);

tests/test/units/sysutils/tw37374.pp

@@ -0,0 +1,193 @@
+program formatfloat_test;
+
+uses
+  SysUtils//, MyFormatFloat
+  ;
+
+var
+  fails: Integer = 0;
+  testCount: Integer = 0;
+
+  procedure Test(AFormat: String; AValue: Double; AResult: String);
+  var
+    s: String;
+  begin
+    s := FormatFloat(AFormat, AValue);
+    if s <> AResult then
+    begin
+      WriteLn('Format(' + AFormat + ', ', AValue:0:6, ') --> ', s, '; SHOULD BE: ', AResult);
+      inc(fails);
+    end;
+    inc(testCount);
+  end;
+
+const
+  VALUES: array[0..4] of Double = (0, 0.00001234, 0.123456, 1.23456, 1123.4567);
+var
+  fmt: String;
+
+begin
+  DefaultFormatSettings.DecimalSeparator := '.';
+  DefaultFormatSettings.ThousandSeparator := ',';
+
+  fmt := '0.00';
+  Test(fmt, VALUES[0], '0.00');
+  Test(fmt, VALUES[1], '0.00');
+  Test(fmt, VALUES[2], '0.12');
+  Test(fmt, VALUES[3], '1.23');
+  Test(fmt, VALUES[4], '1123.46');
+  Test(fmt, -VALUES[1], '-0.00');
+  Test(fmt, -VALUES[2], '-0.12');
+  Test(fmt, -VALUES[3], '-1.23');
+  Test(fmt, -VALUES[4], '-1123.46');
+
+  fmt := '.00';
+  Test(fmt, VALUES[0], '.00');
+  Test(fmt, VALUES[1], '.00');
+  Test(fmt, VALUES[2], '.12');
+  Test(fmt, VALUES[3], '1.23');
+  Test(fmt, VALUES[4], '1123.46');
+  Test(fmt, -VALUES[1], '-.00');
+  Test(fmt, -VALUES[2], '-.12');
+  Test(fmt, -VALUES[3], '-1.23');
+  Test(fmt, -VALUES[4], '-1123.46');
+
+  fmt := '0.00000###';
+  Test(fmt, VALUES[0], '0.00000');
+  Test(fmt, VALUES[1], '0.00001234');
+  Test(fmt, VALUES[2], '0.123456');
+  Test(fmt, VALUES[3], '1.23456');
+  Test(fmt, VALUES[4], '1123.45670');
+  Test(fmt, -VALUES[1], '-0.00001234');
+  Test(fmt, -VALUES[2], '-0.123456');
+  Test(fmt, -VALUES[3], '-1.23456');
+  Test(fmt, -VALUES[4], '-1123.45670');
+
+  fmt := '000';
+  Test(fmt, VALUES[0], '000');
+  Test(fmt, VALUES[1], '000');
+  Test(fmt, VALUES[2], '000');
+  Test(fmt, VALUES[3], '001');
+  Test(fmt, VALUES[4], '1123');
+  Test(fmt, -VALUES[1], '-000');
+  Test(fmt, -VALUES[2], '-000');
+  Test(fmt, -VALUES[3], '-001');
+  Test(fmt, -VALUES[4], '-1123');
+
+  fmt := '0.00E+00';
+  Test(fmt, VALUES[0], '0.00E+00');
+  Test(fmt, VALUES[1], '1.23E-05');
+  Test(fmt, VALUES[2], '1.23E-01');
+  Test(fmt, VALUES[3], '1.23E+00');
+  Test(fmt, VALUES[4], '1.12E+03');
+  Test(fmt, -VALUES[1], '-1.23E-05');
+  Test(fmt, -VALUES[2], '-1.23E-01');
+  Test(fmt, -VALUES[3], '-1.23E+00');
+  Test(fmt, -VALUES[4], '-1.12E+03');
+
+  fmt := '0.00E-00';
+  Test(fmt, VALUES[0], '0.00E00');
+  Test(fmt, VALUES[1], '1.23E-05');
+  Test(fmt, VALUES[2], '1.23E-01');
+  Test(fmt, VALUES[3], '1.23E00');
+  Test(fmt, VALUES[4], '1.12E03');
+  Test(fmt, -VALUES[1], '-1.23E-05');
+  Test(fmt, -VALUES[2], '-1.23E-01');
+  Test(fmt, -VALUES[3], '-1.23E00');
+  Test(fmt, -VALUES[4], '-1.12E03');
+
+  fmt := '0.00 EUR';
+  Test(fmt, VALUES[0], '0.00 EUR');
+  Test(fmt, VALUES[1], '0.00 EUR');
+  Test(fmt, VALUES[2], '0.12 EUR');
+  Test(fmt, VALUES[3], '1.23 EUR');
+  Test(fmt, VALUES[4], '1123.46 EUR');
+  Test(fmt, -VALUES[1], '-0.00 EUR');
+  Test(fmt, -VALUES[2], '-0.12 EUR');
+  Test(fmt, -VALUES[3], '-1.23 EUR');
+  Test(fmt, -VALUES[4], '-1123.46 EUR');
+
+  fmt := '0.00 "EUR"';
+  Test(fmt, VALUES[0], '0.00 EUR');
+  Test(fmt, VALUES[1], '0.00 EUR');
+  Test(fmt, VALUES[2], '0.12 EUR');
+  Test(fmt, VALUES[3], '1.23 EUR');
+  Test(fmt, VALUES[4], '1123.46 EUR');
+  Test(fmt, -VALUES[1], '-0.00 EUR');
+  Test(fmt, -VALUES[2], '-0.12 EUR');
+  Test(fmt, -VALUES[3], '-1.23 EUR');
+  Test(fmt, -VALUES[4], '-1123.46 EUR');
+
+  fmt := '0.00"E+00"';
+  Test(fmt, VALUES[0], '0.00E+00');
+  Test(fmt, VALUES[1], '0.00E+00');
+  Test(fmt, VALUES[2], '0.12E+00');
+  Test(fmt, VALUES[3], '1.23E+00');
+  Test(fmt, VALUES[4], '1123.46E+00');
+  Test(fmt, -VALUES[1], '-0.00E+00');
+  Test(fmt, -VALUES[2], '-0.12E+00');
+  Test(fmt, -VALUES[3], '-1.23E+00');
+  Test(fmt, -VALUES[4], '-1123.46E+00');
+
+  fmt := '#,##0.0';
+  Test(fmt, VALUES[0], '0.0');
+  Test(fmt, VALUES[1], '0.0');
+  Test(fmt, VALUES[2], '0.1');
+  Test(fmt, VALUES[3], '1.2');
+  Test(fmt, VALUES[4], '1,123.5');
+  Test(fmt, -VALUES[1], '-0.0');
+  Test(fmt, -VALUES[2], '-0.1');
+  Test(fmt, -VALUES[3], '-1.2');
+  Test(fmt, -VALUES[4], '-1,123.5');
+
+  fmt := ',0.0';
+  Test(fmt, VALUES[0], '0.0');
+  Test(fmt, VALUES[1], '0.0');
+  Test(fmt, VALUES[2], '0.1');
+  Test(fmt, VALUES[3], '1.2');
+  Test(fmt, VALUES[4], '1,123.5');
+  Test(fmt, -VALUES[1], '-0.0');
+  Test(fmt, -VALUES[2], '-0.1');
+  Test(fmt, -VALUES[3], '-1.2');
+  Test(fmt, -VALUES[4], '-1,123.5');
+
+  fmt := '#,##0.00;(#,##0.00);zero';
+  Test(fmt, VALUES[0], 'zero');
+  Test(fmt, VALUES[1], '0.00');
+  Test(fmt, VALUES[2], '0.12');
+  Test(fmt, VALUES[3], '1.23');
+  Test(fmt, VALUES[4], '1,123.46');
+  Test(fmt, -VALUES[1], '(0.00)');
+  Test(fmt, -VALUES[2], '(0.12)');
+  Test(fmt, -VALUES[3], '(1.23)');
+  Test(fmt, -VALUES[4], '(1,123.46)');
+
+  fmt := '#,##0.00 EUR;(#,##0.00 EUR);zero';
+  Test(fmt, VALUES[0], 'zero');
+  Test(fmt, VALUES[1], '0.00 EUR');
+  Test(fmt, VALUES[2], '0.12 EUR');
+  Test(fmt, VALUES[3], '1.23 EUR');
+  Test(fmt, VALUES[4], '1,123.46 EUR');
+  Test(fmt, -VALUES[1], '(0.00 EUR)');
+  Test(fmt, -VALUES[2], '(0.12 EUR)');
+  Test(fmt, -VALUES[3], '(1.23 EUR)');
+  Test(fmt, -VALUES[4], '(1,123.46 EUR)');
+
+  fmt := 'EUR #,##0.00;(EUR #,##0.00);-';
+  Test(fmt, VALUES[0], '-');
+  Test(fmt, VALUES[1], 'EUR 0.00');
+  Test(fmt, VALUES[2], 'EUR 0.12');
+  Test(fmt, VALUES[3], 'EUR 1.23');
+  Test(fmt, VALUES[4], 'EUR 1,123.46');
+  Test(fmt, -VALUES[1], '(EUR 0.00)');
+  Test(fmt, -VALUES[2], '(EUR 0.12)');
+  Test(fmt, -VALUES[3], '(EUR 1.23)');
+  Test(fmt, -VALUES[4], '(EUR 1,123.46)');
+
+  WriteLn(testCount, ' tests executed.');
+  if fails = 0 then
+    WriteLn('All tests passed.')
+  else
+    halt(1);
+end.
+

tests/webtbs/tw29367.pp

@@ -13,18 +13,63 @@ type
   end;
 
 constructor TFoo.create;
-begin end;
+begin
+  writeln('TFoo.create');
+end;
 
 constructor TBaz.create;
-begin end;
+begin
+  inherited;
+  writeln('TBaz.create');
+end;
+
+var
+  test1tbar: boolean;
+
+procedure test1(o: TFoo; error: longint); overload;
+begin
+  writeln('test1 tfoo');
+  o.free;
+  if test1tbar then
+    halt(error);
+end;
+
+procedure test1(o: TBar; error: longint); overload;
+begin
+  writeln('test1 tbar');
+  o.free;
+  if not test1tbar then
+    halt(error);
+end;
 
+var
+  b: tbar;
 begin
   if not tbar.inheritsfrom(tfoo) then
-    halt(1);
+    begin
+      writeln('error 1');
+      halt(1);
+    end;
   if not tbaz.inheritsfrom(tbar) then
-    halt(2);
-  if tbar.classname<>'TBar' then
-    halt(3);
+    begin
+      writeln('error 2');
+      halt(2);
+   end;
+  if tbar.classname<>'TFoo' then
+    begin
+      writeln('error 3');
+      halt(3);
+    end;
   if tfoo.classname<>'TFoo' then
-    halt(4);
+    begin
+      writeln('error 4');
+      halt(4);
+    end;
+  TBaz.create.free;
+  test1tbar:=false;
+  test1(tfoo.create,5);
+  test1(tbar.create,6);
+  b:=tbar.create;
+  test1tbar:=true;
+  test1(b,7);
 end.

tests/webtbs/tw8180.pp

@@ -10,7 +10,14 @@ type
 
 var
   x : tcl;
+  p: pointer;
+  i: iunknown;
 begin
   x:=tcl.create;
   x._Addref;
+  i:=x as iunknown;
+  if (x as iunknown).queryinterface(xstr,p) <> S_OK then
+    halt(1);
+  if (x as iunknown).queryinterface(iinterface,p) <> S_OK then
+    halt(2);
 end.