* synchronized with trunk

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

compiler/cgobj.pas

@@ -282,6 +282,7 @@ unit cgobj;
           procedure a_loadfpu_ref_cgpara(list : TAsmList;size : tcgsize;const ref : treference;const cgpara : TCGPara);virtual;
 
           procedure a_loadfpu_intreg_reg(list: TAsmList; fromsize, tosize : tcgsize; intreg, fpureg: tregister); virtual;
+          procedure a_loadfpu_reg_intreg(list: TAsmList; fromsize, tosize: tcgsize; fpureg, intreg: tregister); virtual;
 
           { vector register move instructions }
           procedure a_loadmm_reg_reg(list: TAsmList; fromsize, tosize : tcgsize;reg1, reg2: tregister;shuffle : pmmshuffle); virtual;
@@ -1437,7 +1438,9 @@ implementation
              begin
                case getregtype(reg) of
                  R_FPUREGISTER:
-                   a_loadfpu_reg_reg(list,paraloc.size,regsize,paraloc.register,reg)
+                   a_loadfpu_reg_reg(list,paraloc.size,regsize,paraloc.register,reg);
+                 R_INTREGISTER:
+                   a_loadfpu_reg_intreg(list,paraloc.size,regsize,paraloc.register,reg);
                  else
                    internalerror(2015031401);
                  end;
@@ -1974,6 +1977,21 @@ implementation
       end;
 
 
+    procedure tcg.a_loadfpu_reg_intreg(list : TAsmList; fromsize,tosize : tcgsize; fpureg,intreg : tregister);
+      var
+        tmpref: treference;
+      begin
+        if not(tcgsize2size[fromsize] in [4,8]) or
+           not(tcgsize2size[tosize] in [4,8]) or
+           (tcgsize2size[fromsize]<>tcgsize2size[tosize]) then
+          internalerror(2020091201);
+        tg.gettemp(list,tcgsize2size[fromsize],tcgsize2size[fromsize],tt_normal,tmpref);
+        a_loadfpu_reg_ref(list,fromsize,fromsize,fpureg,tmpref);
+        a_load_ref_reg(list,tosize,tosize,tmpref,intreg);
+        tg.ungettemp(list,tmpref);
+      end;
+
+
     procedure tcg.a_op_const_ref(list : TAsmList; Op: TOpCG; size: TCGSize; a: tcgint; const ref: TReference);
       var
         tmpreg : tregister;

compiler/fpcdefs.inc

@@ -341,6 +341,7 @@
   {$define cpuneedsdivhelper}
   {$define cpucapabilities}
   {$define cpurequiresproperalignment}
+  {$define cpufloatintregmov}
 {$endif xtensa}
 
 { Stabs is not officially supported on 64 bit targets by gdb, except on Mac OS X

compiler/hlcg2ll.pas

@@ -2019,19 +2019,7 @@ implementation
                   begin
                     unget_para(paraloc^);
                     gen_alloc_regloc(list,destloc,vardef);
-                    { we can't directly move regular registers into fpu
-                      registers }
-                    if getregtype(paraloc^.register)=R_FPUREGISTER then
-                      begin
-                        { store everything first to memory, then load it in
-                          destloc }
-                        tg.gettemp(list,tcgsize2size[paraloc^.size],para.intsize,tt_persistent,tempref);
-                        cg.a_load_cgparaloc_ref(list,paraloc^,tempref,tcgsize2size[paraloc^.size],tempref.alignment);
-                        cg.a_load_ref_reg(list,int_cgsize(tcgsize2size[paraloc^.size]),destloc.size,tempref,destloc.register);
-                        tg.ungettemp(list,tempref);
-                      end
-                    else
-                      cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,sizeof(aint));
+                    cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,sizeof(aint));
                   end;
               end;
           end;

compiler/ncgcnv.pas

@@ -806,8 +806,19 @@ interface
             (location.loc=LOC_CONSTANT)
            ) or
            ((resultdef.typ=floatdef) xor (location.loc in [LOC_CFPUREGISTER,LOC_FPUREGISTER,LOC_CMMREGISTER,LOC_MMREGISTER])) then
-          hlcg.location_force_mem(current_asmdata.CurrAsmList,location,left.resultdef);
-
+          begin
+            { check if the CPU supports direct moves between int and fpu registers and take advantage of it }
+{$ifdef cpufloatintregmov}
+            if (resultdef.typ<>floatdef) and (location.loc in [LOC_CFPUREGISTER,LOC_FPUREGISTER]) then
+              begin
+                location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
+                location.register:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
+                cg.a_loadfpu_reg_intreg(current_asmdata.CurrAsmList,left.location.size,location.size,left.location.register,location.register);
+              end
+            else
+{$endif cpufloatintregmov}
+              hlcg.location_force_mem(current_asmdata.CurrAsmList,location,left.resultdef);
+          end;
         { but use the new size, but we don't know the size of all arrays }
         newsize:=def_cgsize(resultdef);
         location.size:=newsize;

compiler/rgobj.pas

@@ -641,10 +641,17 @@ 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
           with reginfo[i] do
-            if real_reg_interferences>=usable_registers_cnt then
+            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
@@ -1699,15 +1706,6 @@ unit rgobj;
       for i:=selectstack.length downto 1 do
         begin
           n:=selectstack.buf^[i-1];
-          { Always spill the register if it has the initial memory location
-            and is used only once (weight<=200). This allows to access the
-            memory location directly, without preloading it to a register. }
-          with reginfo[n] do
-            if (ri_has_initial_loc in flags) and (weight<=200) then
-              begin
-                spillednodes.add(n);
-                continue;
-              end;
           {Create a list of colours that we cannot assign to n.}
           adj_colours:=[];
           adj:=reginfo[n].adjlist;

compiler/riscv32/nrv32mat.pas

@@ -100,7 +100,7 @@ implementation
         else
           op:=A_DIVU;
 
-        current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(op,denum,num,denum));
+        current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(op,num,num,denum));
       end;
 
     procedure trv32moddivnode.emit_mod_reg_reg(signed: boolean; denum, num: tregister);
@@ -112,7 +112,7 @@ implementation
         else
           op:=A_REMU;
 
-        current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(op,denum,num,denum));
+        current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(op,num,num,denum));
       end;
 
 

compiler/xtensa/aasmcpu.pas

@@ -106,6 +106,8 @@ uses
     function spilling_create_load(const ref:treference;r:tregister):Taicpu;
     function spilling_create_store(r:tregister; const ref:treference):Taicpu;
 
+    function setoppostfix(i : taicpu;pf : toppostfix) : taicpu;
+
 implementation
 
 uses cutils, cclasses;
@@ -495,6 +497,13 @@ uses cutils, cclasses;
       end;
 
 
+    function setoppostfix(i : taicpu;pf : toppostfix) : taicpu;
+      begin
+        i.oppostfix:=pf;
+        result:=i;
+      end;
+
+
     procedure InitAsm;
       begin
       end;

compiler/xtensa/cgcpu.pas

@@ -77,6 +77,9 @@ interface
         procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tcgsize; const ref: treference; reg: tregister);override;
         procedure a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tcgsize; reg: tregister; const ref: treference);override;
 
+        procedure a_loadfpu_intreg_reg(list: TAsmList; fromsize, tosize: tcgsize; intreg, fpureg: tregister);override;
+        procedure a_loadfpu_reg_intreg(list: TAsmList; fromsize, tosize: tcgsize; fpureg, intreg: tregister);override;
+
         procedure maybeadjustresult(list: TAsmList; op: TOpCg; size: tcgsize; dst: tregister);
 
         procedure g_overflowcheck(list: TAsmList; const Loc:tlocation; def:tdef);override;
@@ -1196,6 +1199,24 @@ implementation
        end;
 
 
+    procedure tcgcpu.a_loadfpu_intreg_reg(list : TAsmList; fromsize,tosize : tcgsize; intreg,fpureg : tregister);
+      begin
+        if not(tcgsize2size[fromsize]=4) or
+           not(tcgsize2size[tosize]=4) then
+          internalerror(2020091102);
+        list.concat(taicpu.op_reg_reg(A_WFR,fpureg,intreg));
+      end;
+
+
+    procedure tcgcpu.a_loadfpu_reg_intreg(list : TAsmList; fromsize,tosize : tcgsize; fpureg,intreg : tregister);
+      begin
+        if not(tcgsize2size[fromsize]=4) or
+           not(tcgsize2size[tosize]=4) then
+          internalerror(2020091202);
+        list.concat(taicpu.op_reg_reg(A_RFR,intreg,fpureg));
+      end;
+
+
     procedure tcgcpu.maybeadjustresult(list : TAsmList; op : TOpCg; size : tcgsize; dst : tregister);
       const
         overflowops = [OP_MUL,OP_SHL,OP_ADD,OP_SUB,OP_NEG];

compiler/xtensa/ncpuinl.pas

@@ -30,12 +30,16 @@ unit ncpuinl;
 
     type
       tcpuinlineNode = class(tcginlinenode)
+        function first_abs_real: tnode; override;
         procedure second_abs_long; override;
+        procedure second_abs_real; override;
       end;
 
   implementation
 
     uses
+      cpuinfo,
+      verbose,globals,
       compinnr,
       aasmdata,
       aasmcpu,
@@ -58,6 +62,29 @@ unit ncpuinl;
       end;
 
 
+    function tcpuinlinenode.first_abs_real : tnode;
+      begin
+        result:=nil;
+        if is_single(left.resultdef) and (FPUXTENSA_SINGLE in fpu_capabilities[current_settings.fputype]) then
+          expectloc:=LOC_FPUREGISTER
+        else
+          result:=inherited first_abs_real;
+      end;
+
+
+    procedure tcpuinlinenode.second_abs_real;
+      begin
+        if not(is_single(resultdef)) then
+          InternalError(2020091101);
+        secondpass(left);
+        hlcg.location_force_fpureg(current_asmdata.CurrAsmList,left.location,left.resultdef,true);
+        location_reset(location,LOC_FPUREGISTER,OS_F32);
+        location.register:=cg.getfpuregister(current_asmdata.CurrAsmList,location.size);
+        current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_ABS,location.register,left.location.register),PF_S));
+      end;
+
+
+
 begin
   cinlinenode:=tcpuinlinenode;
 end.

packages/fpmkunit/src/fpmkunit.pp

@@ -488,7 +488,7 @@ Type
     Function GetValue(AName : String) : String;
     Function GetValue(const AName,Args : String) : String; virtual;
     Function ReplaceStrings(Const ASource : String; Const MaxDepth: Integer = 10) : String; virtual;
-    Function Substitute(Const Source : String; Macros : Array of string) : String; virtual;
+    Function Substitute(Const Source : String; const Macros : Array of string) : String; virtual;
   end;
 
   { TPackageDictionary }
@@ -855,6 +855,9 @@ Type
     // Is set when all sourcefiles are found
     FAllFilesResolved: boolean;
     FPackageVariants: TFPList;
+{$ifndef NO_THREADING}
+    FResolveDirsCS: TRTLCriticalSection;
+{$endif}
     Function GetDescription : string;
     function GetDictionary: TDictionary;
     Function GetFileName : string;
@@ -894,6 +897,8 @@ Type
     procedure SetDefaultPackageVariant;
     procedure LoadUnitConfigFromFile(Const AFileName: String);
     procedure SaveUnitConfigToFile(Const AFileName: String;ACPU:TCPU;AOS:TOS);
+    procedure EnterResolveDirsCS;
+    procedure LeaveResolveDirsCS;
     Property Version : String Read GetVersion Write SetVersion;
     Property FileName : String Read GetFileName Write FFileName;
     Property ShortName : String Read GetShortName Write FShortName;
@@ -1304,9 +1309,9 @@ Type
     Procedure CheckPackages; virtual;
     Procedure CreateBuildEngine; virtual;
     Procedure Error(const Msg : String);
-    Procedure Error(const Fmt : String; Args : Array of const);
+    Procedure Error(const Fmt : String; const Args : Array of const);
     Procedure AnalyzeOptions;
-    Procedure Usage(const FMT : String; Args : Array of const);
+    Procedure Usage(const FMT : String; const Args : Array of const);
     Procedure Compile(Force : Boolean); virtual;
     Procedure Clean(AllTargets: boolean); virtual;
     Procedure Install(ForceBuild : Boolean); virtual;
@@ -3683,6 +3688,9 @@ begin
   // Implicit dependency on RTL
   FDependencies.Add('rtl');
   FSupportBuildModes:=[bmBuildUnit, bmOneByOne];
+{$ifndef NO_THREADING}
+  InitCriticalSection(FResolveDirsCS);
+{$endif}
 end;
 
 
@@ -3690,6 +3698,9 @@ destructor TPackage.destroy;
 var
   i: integer;
 begin
+{$ifndef NO_THREADING}
+  DoneCriticalSection(FResolveDirsCS);
+{$endif}
   FreeAndNil(FDictionary);
   FreeAndNil(FDependencies);
   FreeAndNil(FInstallFiles);
@@ -4316,6 +4327,20 @@ begin
   end;
 end;
 
+procedure TPackage.EnterResolveDirsCS;
+begin
+{$ifndef NO_THREADING}
+   EnterCriticalSection(FResolveDirsCS);
+{$endif}
+end;
+
+procedure TPackage.LeaveResolveDirsCS;
+begin
+{$ifndef NO_THREADING}
+   LeaveCriticalSection(FResolveDirsCS);
+{$endif}
+end;
+
 
 
 {****************************************************************************
@@ -5040,7 +5065,7 @@ begin
 end;
 
 
-procedure TCustomInstaller.Error(const Fmt: String; Args: array of const);
+procedure TCustomInstaller.Error(const Fmt: String; const Args: array of const);
 begin
   Raise EInstallerError.CreateFmt(Fmt,Args);
 end;
@@ -5377,7 +5402,7 @@ begin
 end;
 
 
-procedure TCustomInstaller.Usage(const FMT: String; Args: array of const);
+procedure TCustomInstaller.Usage(const FMT: String; const Args: array of const);
 
   Procedure LogCmd(const LC,Msg : String);
   begin
@@ -6602,27 +6627,36 @@ var
   i: Integer;
   Continue: Boolean;
 begin
-  if APackage.UnitDir='' then
-    begin
-      Log(vldebug, SDbgSearchExtDepPath, [APackage.Name]);
-      GetPluginManager.BeforeResolvePackagePath(Self, APackage, Continue);
-      if Continue then
-        begin
-        for I := 0 to Defaults.SearchPath.Count-1 do
+{$ifndef NO_THREADING}
+  APackage.EnterResolveDirsCS;
+  try
+{$endif}
+    if APackage.UnitDir='' then
+      begin
+        Log(vldebug, SDbgSearchExtDepPath, [APackage.Name]);
+        GetPluginManager.BeforeResolvePackagePath(Self, APackage, Continue);
+        if Continue then
           begin
-            if Defaults.SearchPath[i]<>'' then
-              GetPluginManager.ResolvePackagePath(Self, APackage, Defaults.SearchPath[i], Continue);
-            if not Continue then
-              Break
-          end;
+          for I := 0 to Defaults.SearchPath.Count-1 do
+            begin
+              if Defaults.SearchPath[i]<>'' then
+                GetPluginManager.ResolvePackagePath(Self, APackage, Defaults.SearchPath[i], Continue);
+              if not Continue then
+                Break
+            end;
 
-        if Continue then
-          GetPluginManager.AfterResolvePackagePath(Self, APackage, Continue);
-        end;
+          if Continue then
+            GetPluginManager.AfterResolvePackagePath(Self, APackage, Continue);
+          end;
 
-      if APackage.UnitDir = '' then
-        APackage.UnitDir := DirNotFound
-    end;
+        if APackage.UnitDir = '' then
+          APackage.UnitDir := DirNotFound
+      end;
+{$ifndef NO_THREADING}
+  finally
+    APackage.LeaveResolveDirsCS;
+  end;
+{$endif}
 end;
 
 
@@ -9488,7 +9522,7 @@ begin
 end;
 
 
-Function TDictionary.Substitute(Const Source : String; Macros : Array of string) : String;
+Function TDictionary.Substitute(Const Source : String; const Macros : Array of string) : String;
 Var
   I : Integer;
 begin
@@ -9499,6 +9533,7 @@ begin
       Inc(I,2);
     end;
   Result:=ReplaceStrings(Source);
+  I:=0;
   While I<High(Macros) do
     begin
       RemoveItem(Macros[i]);

packages/pastojs/src/fppas2js.pp

@@ -1744,8 +1744,12 @@ type
 
   TInterfaceSectionContext = Class(TSectionContext)
   public
+    ImplContext: TSectionContext;
     ImplHeaderStatements: TFPList;
+    ImplSrcElements: TJSSourceElements;
+    ImplHeaderIndex: integer; // index in TJSSourceElements(JSElement).Statements
     destructor Destroy; override;
+    procedure AddImplHeaderStatement(JS: TJSElement);
   end;
 
   { TDotContext - used for converting eopSubIdent }
@@ -1994,7 +1998,7 @@ type
       Full: boolean = false; Ref: TResolvedReference = nil): TJSElement; virtual;
     Function CreateGlobalTypePath(El: TPasType; AContext : TConvertContext): string; virtual;
     // section
-    Function CreateImplementationSection(El: TPasModule; AContext: TInterfaceSectionContext): TJSFunctionDeclarationStatement; virtual;
+    Function CreateImplementationSection(El: TPasModule; IntfContext: TInterfaceSectionContext): TJSFunctionDeclarationStatement; virtual;
     Procedure CreateInitSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); virtual;
     Procedure AddHeaderStatement(JS: TJSElement; PosEl: TPasElement; aContext: TConvertContext); virtual;
     Procedure AddImplHeaderStatement(JS: TJSElement; PosEl: TPasElement; aContext: TConvertContext); virtual;
@@ -2393,6 +2397,29 @@ begin
   inherited Destroy;
 end;
 
+procedure TInterfaceSectionContext.AddImplHeaderStatement(JS: TJSElement);
+begin
+  if JS=nil then exit;
+  if ImplContext<>nil then
+    begin
+    // unit impl is currently created
+    ImplContext.AddHeaderStatement(JS);
+    end
+  else if ImplSrcElements<>nil then
+    begin
+    // unit impl finished -> e.g. during the initialization section
+    ImplSrcElements.Statements.InsertNode(ImplHeaderIndex).Node:=JS;
+    inc(ImplHeaderIndex);
+    end
+  else
+    begin
+    // unit impl not yet created
+    if ImplHeaderStatements=nil then
+      ImplHeaderStatements:=TFPList.Create;
+    ImplHeaderStatements.Add(JS);
+    end;
+end;
+
 { TPas2JSResolverHub }
 
 function TPas2JSResolverHub.GetJSDelaySpecializes(Index: integer
@@ -16771,7 +16798,7 @@ begin
 end;
 
 function TPasToJSConverter.CreateImplementationSection(El: TPasModule;
-  AContext: TInterfaceSectionContext): TJSFunctionDeclarationStatement;
+  IntfContext: TInterfaceSectionContext): TJSFunctionDeclarationStatement;
 var
   Src: TJSSourceElements;
   ImplContext: TSectionContext;
@@ -16784,33 +16811,37 @@ begin
   // create function(){}
   FunDecl:=CreateFunctionSt(El.ImplementationSection,true,true);
   Src:=TJSSourceElements(FunDecl.AFunction.Body.A);
+  IntfContext.ImplSrcElements:=Src;
 
   // create section context (a function)
-  ImplContext:=TSectionContext.Create(El.ImplementationSection,Src,AContext);
+  ImplContext:=TSectionContext.Create(El.ImplementationSection,Src,IntfContext);
   try
+    IntfContext.ImplContext:=ImplContext;
     // ToDo: IntfContext.ThisPas:=El;
     // ToDo: IntfContext.ThisKind:=cctkGlobal;
 
     // add pending impl header statements
-    if AContext.ImplHeaderStatements<>nil then
+    if IntfContext.ImplHeaderStatements<>nil then
       begin
-      for i:=0 to AContext.ImplHeaderStatements.Count-1 do
+      for i:=0 to IntfContext.ImplHeaderStatements.Count-1 do
         begin
-        JS:=TJSElement(AContext.ImplHeaderStatements[i]);
+        JS:=TJSElement(IntfContext.ImplHeaderStatements[i]);
         ImplContext.AddHeaderStatement(JS);
-        AContext.ImplHeaderStatements[i]:=nil;
+        IntfContext.ImplHeaderStatements[i]:=nil;
         end;
-      FreeAndNil(AContext.ImplHeaderStatements);
+      FreeAndNil(IntfContext.ImplHeaderStatements);
       end;
 
     // create implementation declarations
     ImplDecl:=ConvertDeclarations(El.ImplementationSection,ImplContext);
     if ImplDecl<>nil then
       RaiseInconsistency(20170910175032,El); // elements should have been added directly
+    IntfContext.ImplHeaderIndex:=ImplContext.HeaderIndex;
     if Src.Statements.Count=0 then
       exit; // no implementation
     Result:=FunDecl;
   finally
+    IntfContext.ImplContext:=nil;
     ImplContext.Free;
     if Result=nil then
       FunDecl.Free;
@@ -16849,25 +16880,13 @@ end;
 procedure TPasToJSConverter.AddImplHeaderStatement(JS: TJSElement;
   PosEl: TPasElement; aContext: TConvertContext);
 var
-  SectionCtx: TSectionContext;
   IntfSec: TInterfaceSectionContext;
 begin
   if JS=nil then exit;
-  SectionCtx:=TSectionContext(aContext.GetContextOfType(TSectionContext));
-  if SectionCtx=nil then
+  IntfSec:=TInterfaceSectionContext(aContext.GetContextOfType(TInterfaceSectionContext));
+  if IntfSec=nil then
     RaiseNotSupported(PosEl,aContext,20200606142555);
-  if SectionCtx.PasElement is TImplementationSection then
-    SectionCtx.AddHeaderStatement(JS)
-  else if SectionCtx is TInterfaceSectionContext then
-    begin
-    // add pending impl header statement
-    IntfSec:=TInterfaceSectionContext(SectionCtx);
-    if IntfSec.ImplHeaderStatements=nil then
-      IntfSec.ImplHeaderStatements:=TFPList.Create;
-    IntfSec.ImplHeaderStatements.Add(JS);
-    end
-  else
-    RaiseNotSupported(PosEl,aContext,20200911165632);
+  IntfSec.AddImplHeaderStatement(JS);
 end;
 
 procedure TPasToJSConverter.AddDelayedInits(El: TPasProgram;

packages/pastojs/tests/tcoptimizations.pas

@@ -303,6 +303,8 @@ begin
     '  end;',
     '  TBear = class',
     '  end;',
+    '  TFrog = class',
+    '  end;',
     'var Ant: TAnt;',
     '']),
   LinesToStr([
@@ -347,6 +349,7 @@ begin
   '  Ant:=TAnt.Create;', // init to impl-uses
   '  Bird:=TBird.Create;', // init to intf-uses
   '  Eagle:=TEagle.Create;', // init to intf-JS
+  '  TFrog.Create;', // only in init to impl-uses
   '  Eagle.Fly;',
   '  RedAnt.Run;',
   '']);
@@ -359,6 +362,7 @@ begin
     'var $lm1 = null;',
     'var $lt1 = null;',
     'var $lt2 = null;',
+    'var $lt3 = null;',
     'rtl.createClass($mod, "TEagle", $lt, function () {',
     '  this.Fly = function () {',
     '    $impl.TRedAnt.$create("Create");',
@@ -373,6 +377,7 @@ begin
     '$impl.Ant = $lt1.$create("Create");',
     '$impl.Bird = $lt.$create("Create");',
     '$impl.Eagle = $mod.TEagle.$create("Create");',
+    '$lt3.$create("Create");',
     '$impl.Eagle.Fly();',
     '$impl.RedAnt.Run();',
     '']),
@@ -380,6 +385,7 @@ begin
     '$lm1 = pas.UnitB;',
     '$lt1 = $lm1.TAnt;',
     '$lt2 = $lm1.TBear;',
+    '$lt3 = $lm1.TFrog;',
     'rtl.createClass($impl, "TRedAnt", $lt1, function () {',
     '  this.Run = function () {',
     '    $impl.TRedAnt.$create("Create");',

rtl/inc/text.inc

@@ -96,6 +96,12 @@ end;
 Procedure Assign(out t:Text;const s : UnicodeString);
 begin
   InitText(t);
+  if Length (S) >= Length (TextRec.Name) then
+{ The last character of TextRec.Name needs to be #0 }
+   begin
+     InOutRes:=3;
+     Exit;
+   end;
 {$ifdef FPC_ANSI_TEXTFILEREC}
   TextRec(t).Name:=ToSingleByteFileSystemEncodedFileName(S);
 {$else FPC_ANSI_TEXTFILEREC}
@@ -109,12 +115,29 @@ end;
 
 {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
 Procedure Assign(out t:Text;const s: RawByteString);
+{$ifdef FPC_ANSI_TEXTFILEREC}
+var
+  R: RawByteString;
+{$endif FPC_ANSI_TEXTFILEREC}
 Begin
   InitText(t);
 {$ifdef FPC_ANSI_TEXTFILEREC}
   { ensure the characters in the record's filename are encoded correctly }
-  TextRec(t).Name:=ToSingleByteFileSystemEncodedFileName(S);
+  R:=ToSingleByteFileSystemEncodedFileName(S);
+  if Length (R) >= Length (TextRec.Name) then
+{ The last character of TextRec.Name needs to be #0 }
+   begin
+     InOutRes:=3;
+     Exit;
+   end;
+  TextRec(t).Name:=R;
 {$else FPC_ANSI_TEXTFILEREC}
+  if Length (S) >= Length (TextRec.Name) then
+{ The last character of TextRec.Name needs to be #0 }
+   begin
+     InOutRes:=3;
+     Exit;
+   end;
   TextRec(t).Name:=S;
 {$endif FPC_ANSI_TEXTFILEREC}
   { null terminate, since the name array is regularly used as p(wide)char }
@@ -138,27 +161,61 @@ End;
 
 
 Procedure Assign(out t:Text;const p: PAnsiChar);
+var
+{$IFDEF FPC_HAS_FEATURE_ANSISTRINGS}
+  S: ansistring;
+{$ELSE FPC_HAS_FEATURE_ANSISTRINGS}
+  Counter: SizeInt;
+{$ENDIF FPC_HAS_FEATURE_ANSISTRINGS}
 Begin
 {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
-  Assign(t,AnsiString(p));
+  S := AnsiString (P);
+  if Length (S) >= Length (TextRec.Name) then
+{ The last character of TextRec.Name needs to be #0 }
+   begin
+     InOutRes:=3;
+     Exit;
+   end;
+  Assign(t,S);
 {$else FPC_HAS_FEATURE_ANSISTRINGS}
   { no use in making this the one that does the work, since the name field is
     limited to 255 characters anyway }
-  Assign(t,strpas(p));
+{  Assign(t,strpas(p));}
+  { TH: The length of name field may be extended sooner or later, let's play
+    safely }
+  Counter := IndexByte(P^,-1,0);
+  if Counter >= Length (TextRec.Name) then
+{ The last character of TextRec.Name needs to be #0 }
+   begin
+     InOutRes:=3;
+     Exit;
+   end;
+  Move(P^,TextRec(t).Name,counter+1);
 {$endif FPC_HAS_FEATURE_ANSISTRINGS}
 End;
 
 
 Procedure Assign(out t:Text;const c: AnsiChar);
+{$IFNDEF FPC_HAS_FEATURE_ANSISTRINGS}
+var
+  Counter: SizeInt;
+{$ENDIF FPC_HAS_FEATURE_ANSISTRINGS}
 Begin
 {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
   Assign(t,AnsiString(c));
 {$else FPC_HAS_FEATURE_ANSISTRINGS}
-  Assign(t,ShortString(c));
+  Counter := IndexByte(c,-1,0);
+  if Counter >= Length (TextRec.Name) then
+{ The last character of TextRec.Name needs to be #0 }
+   begin
+     InOutRes:=3;
+     Exit;
+   end;
+  Move(c,TextRec(F).Name,counter+1);
+{  Assign(t,ShortString(c));}
 {$endif FPC_HAS_FEATURE_ANSISTRINGS}
 End;
 
-
 Procedure Close(var t : Text);[IOCheck];
 Begin
   if InOutRes<>0 then
@@ -472,6 +529,8 @@ Begin
           (reads = 1) then
          begin
            oldfilepos := Do_FilePos(TextRec(t).handle) - TextRec(t).BufEnd;
+           if InOutRes <> 0 then
+             isdevice := true;
            InOutRes:=0;
          end;
        FileFunc(TextRec(t).InOutFunc)(TextRec(t));
@@ -506,7 +565,7 @@ Begin
   if not isdevice then
     { if we didn't modify the buffer, simply restore the BufPos and BufEnd  }
     { (the latter because it's now probably set to zero because nothing was }
-    {  was read anymore)                                                    }
+    { read anymore)                                                         }
     if (reads = 0) then
       begin
         TextRec(t).BufPos:=oldbufpos;
@@ -515,10 +574,15 @@ Begin
     { otherwise return to the old filepos and reset the buffer }
     else
       begin
+        InOutRes := 0;
         do_seek(TextRec(t).handle,oldfilepos);
-        InOutRes:=0;
-        FileFunc(TextRec(t).InOutFunc)(TextRec(t));
-        TextRec(t).BufPos:=oldbufpos;
+        if InOutRes = 0 then
+          begin
+            FileFunc(TextRec(t).InOutFunc)(TextRec(t));
+            TextRec(t).BufPos:=oldbufpos;
+          end
+        else
+          InOutRes:=0;
       end;
 End;
 

rtl/win/sysutils.pp

@@ -415,7 +415,15 @@ begin
 end;
 
 
-function FileGetSymLinkTargetInt(const FileName: UnicodeString; out SymLinkRec: TUnicodeSymLinkRec; RaiseErrorOnMissing: Boolean): Boolean;
+type
+  TSymLinkResult = (
+    slrOk,
+    slrNoSymLink,
+    slrError
+  );
+
+
+function FileGetSymLinkTargetInt(const FileName: UnicodeString; out SymLinkRec: TUnicodeSymLinkRec; RaiseErrorOnMissing: Boolean): TSymLinkResult;
 { reparse point specific declarations from Windows headers }
 const
   IO_REPARSE_TAG_MOUNT_POINT = $A0000003;
@@ -451,6 +459,7 @@ var
   PBuffer: ^TReparseDataBuffer;
   BytesReturned: DWORD;
 begin
+  Result := slrError;
   SymLinkRec := Default(TUnicodeSymLinkRec);
 
   HFile := CreateFileW(PUnicodeChar(FileName), FILE_READ_EA, CShareAny, Nil, OPEN_EXISTING, COpenReparse, 0);
@@ -487,8 +496,10 @@ begin
               raise EDirectoryNotFoundException.Create(SysErrorMessage(GetLastOSError))
             else
               SymLinkRec.TargetName := '';
-          end else
+          end else begin
             SetLastError(ERROR_REPARSE_TAG_INVALID);
+            Result := slrNoSymLink;
+          end;
         end else
           SetLastError(ERROR_REPARSE_TAG_INVALID);
       finally
@@ -497,13 +508,15 @@ begin
     finally
       CloseHandle(HFile);
     end;
-  Result := SymLinkRec.TargetName <> '';
+
+  if SymLinkRec.TargetName <> '' then
+    Result := slrOk
 end;
 
 
 function FileGetSymLinkTarget(const FileName: UnicodeString; out SymLinkRec: TUnicodeSymLinkRec): Boolean;
 begin
-  Result := FileGetSymLinkTargetInt(FileName, SymLinkRec, True);
+  Result := FileGetSymLinkTargetInt(FileName, SymLinkRec, True) = slrOk;
 end;
 
 
@@ -526,14 +539,6 @@ const
     end;
   end;
 
-  function LinkFileExists: Boolean;
-  var
-    slr: TUnicodeSymLinkRec;
-  begin
-    Result := FileGetSymLinkTargetInt(FileOrDirName, slr, False) and
-                FileOrDirExists(slr.TargetName, CheckDir, False);
-  end;
-
 const
   CNotExistsErrors = [
     ERROR_FILE_NOT_FOUND,
@@ -548,14 +553,25 @@ const
   ];
 var
   Attr : DWord;
+  slr : TUnicodeSymLinkRec;
+  res : TSymLinkResult;
 begin
   Attr := GetFileAttributesW(PUnicodeChar(FileOrDirName));
   if Attr = INVALID_FILE_ATTRIBUTES then
     Result := not (GetLastError in CNotExistsErrors) and FoundByEnum
   else begin
     Result := (Attr and FILE_ATTRIBUTE_DIRECTORY) = CDirAttributes[CheckDir];
-    if Result and FollowLink and ((Attr and FILE_ATTRIBUTE_REPARSE_POINT) <> 0) then
-      Result := LinkFileExists;
+    if Result and FollowLink and ((Attr and FILE_ATTRIBUTE_REPARSE_POINT) <> 0) then begin
+      res := FileGetSymLinkTargetInt(FileOrDirName, slr, False);
+      case res of
+        slrOk:
+          Result := FileOrDirExists(slr.TargetName, CheckDir, False);
+        slrNoSymLink:
+          Result := True;
+        else
+          Result := False;
+      end;
+    end;
   end;
 end;
 

tests/test/units/system/tabs.pp

@@ -232,6 +232,51 @@ procedure fail;
       WriteLn('Success!');
   end;
 
+
+ procedure test_abs_single;
+  var
+   _result : boolean;
+   value : single;
+   value1: single;
+  begin
+    _result := true;
+    Write('Abs() test with single type...');
+
+    value := VALUE_ONE_REAL;
+    if (trunc(abs(value)) <> trunc(RESULT_CONST_ONE_REAL))  then
+       _result := false;
+
+    value := VALUE_THREE_REAL;
+    if trunc(abs(value)) <> trunc(RESULT_CONST_THREE_REAL) then
+       _result := false;
+
+    value := VALUE_FOUR_REAL;
+    if trunc(abs(value)) <> trunc(RESULT_CONST_FOUR_REAL) then
+       _result := false;
+
+    value := VALUE_ONE_REAL;
+    value1 := abs(value);
+    if trunc(value1) <> trunc(RESULT_ONE_REAL) then
+       _result := false;
+
+    value := VALUE_THREE_REAL;
+    value1 := abs(value);
+    if trunc(value1) <> trunc(RESULT_THREE_REAL) then
+       _result := false;
+
+    value := VALUE_FOUR_REAL;
+    value1 := abs(value);
+    if trunc(value1) <> trunc(RESULT_FOUR_REAL) then
+       _result := false;
+
+    if not _result then
+      fail
+    else
+      WriteLn('Success!');
+  end;
+
+
+
  procedure test_abs_real;
   var
    _result : boolean;
@@ -294,6 +339,7 @@ Begin
   test_abs_currency;
 {$endif SKIP_CURRENCY_TEST}
   test_abs_real;
+  test_abs_single;
   test_abs_longint;
   test_abs_int64;
 end.