* synchronized with trunk

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

.gitattributes

@@ -167,6 +167,7 @@ compiler/comphook.pas svneol=native#text/plain
 compiler/compiler.pas svneol=native#text/plain
 compiler/compinnr.pas svneol=native#text/plain
 compiler/comprsrc.pas svneol=native#text/plain
+compiler/comptty.pas svneol=native#text/plain
 compiler/constexp.pas svneol=native#text/x-pascal
 compiler/cprofile.pas svneol=native#text/pascal
 compiler/crefs.pas svneol=native#text/plain
@@ -4398,6 +4399,9 @@ packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_8.wav.raw -text svneol
 packages/fcl-sound/tests/data/wav/reader/valid/euphoric_tape.wav -text svneol=unset#audio/x-wav
 packages/fcl-sound/tests/data/wav/reader/valid/euphoric_tape.wav.info.txt svneol=native#text/plain
 packages/fcl-sound/tests/data/wav/reader/valid/euphoric_tape.wav.raw -text svneol=unset#application/octet-stream
+packages/fcl-sound/tests/data/wav/reader/valid/odd_fmt_size.wav -text svneol=unset#audio/x-wav
+packages/fcl-sound/tests/data/wav/reader/valid/odd_fmt_size.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/odd_fmt_size.wav.raw -text svneol=unset#application/octet-stream
 packages/fcl-sound/tests/tcwavreader.pas svneol=native#text/plain
 packages/fcl-sound/tests/testfclsound.lpi svneol=native#text/plain
 packages/fcl-sound/tests/testfclsound.lpr svneol=native#text/plain
@@ -11785,6 +11789,7 @@ rtl/objpas/sysutils/sysutilh.inc svneol=native#text/plain
 rtl/objpas/sysutils/sysutils.inc svneol=native#text/plain
 rtl/objpas/sysutils/syswide.inc svneol=native#text/plain
 rtl/objpas/sysutils/syswideh.inc svneol=native#text/plain
+rtl/objpas/sysutils/tzenv.inc svneol=native#text/plain
 rtl/objpas/types.pp svneol=native#text/plain
 rtl/objpas/typinfo.pp svneol=native#text/plain
 rtl/objpas/unicodedata.inc svneol=native#text/pascal
@@ -14980,6 +14985,7 @@ tests/test/tfma1.inc svneol=native#text/plain
 tests/test/tfma1a64.pp svneol=native#text/pascal
 tests/test/tfma1arm.pp svneol=native#text/pascal
 tests/test/tfma1x86.pp svneol=native#text/pascal
+tests/test/tfma1xtensa.pp svneol=native#text/pascal
 tests/test/tforin1.pp svneol=native#text/pascal
 tests/test/tforin10.pp svneol=native#text/plain
 tests/test/tforin11.pp svneol=native#text/plain

compiler/aarch64/aasmcpu.pas

@@ -188,6 +188,8 @@ uses
          constructor op_reg_reg_reg_shifterop(op : tasmop;_op1,_op2,_op3 : tregister; const _op4 : tshifterop);
          constructor op_reg_reg_reg_cond(op : tasmop;_op1,_op2,_op3 : tregister; const _op4: tasmcond);
 
+         constructor op_const_ref(op:tasmop; _op1: aint; _op2: treference);
+
          { this is for Jmp instructions }
          constructor op_cond_sym(op : tasmop;cond:TAsmCond;_op1 : tasmsymbol);
 
@@ -544,6 +546,15 @@ implementation
        end;
 
 
+     constructor taicpu.op_const_ref(op : tasmop; _op1 : aint; _op2 : treference);
+      begin
+         inherited create(op);
+         ops:=2;
+         loadconst(0,_op1);
+         loadref(1,_op2);
+      end;
+
+
     constructor taicpu.op_cond_sym(op : tasmop;cond:TAsmCond;_op1 : tasmsymbol);
       begin
          inherited create(op);
@@ -552,6 +563,7 @@ implementation
          loadsymbol(0,_op1,0);
       end;
 
+
     constructor taicpu.op_regset_reg_ref(op: tasmop; basereg: tregister; nregs: byte; const ref: treference);
       begin
         inherited create(op);

compiler/aarch64/aoptcpu.pas

@@ -538,6 +538,27 @@ Implementation
           DebugMsg(SPeepholeOptimization + 'FMovFMov2FMov done', p);
           Result:=true;
         end;
+      { not enabled as apparently not happening
+      if MatchOpType(taicpu(p),top_reg,top_reg) and
+        GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[0]^.reg) and
+        MatchInstruction(hp1, [A_FSUB,A_FADD,A_FNEG,A_FMUL,A_FSQRT,A_FDIV,A_FABS], [PF_None]) and
+        (MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[1]^) or
+         ((taicpu(hp1).ops=3) and MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[2]^))
+        ) and
+        RegEndofLife(taicpu(p).oper[0]^.reg,taicpu(hp1)) and
+        not(RegUsedBetween(taicpu(p).oper[0]^.reg,p,hp1)) then
+        begin
+          DebugMsg(SPeepholeOptimization + 'FMovFOp2FOp done', hp1);
+          AllocRegBetween(taicpu(hp1).oper[1]^.reg,p,hp1,UsedRegs);
+          if MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[1]^) then
+            taicpu(hp1).oper[1]^.reg:=taicpu(p).oper[1]^.reg;
+          if (taicpu(hp1).ops=3) and MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[2]^) then
+            taicpu(hp1).oper[2]^.reg:=taicpu(p).oper[1]^.reg;
+          RemoveCurrentP(p);
+          Result:=true;
+          exit;
+        end;
+      }
     end;
 
 
@@ -772,6 +793,11 @@ Implementation
             A_SXTH:
               Result:=OptPass1SXTH(p);
 //            A_VLDR,
+            A_FMADD,
+            A_FMSUB,
+            A_FNMADD,
+            A_FNMSUB,
+            A_FNMUL,
             A_FADD,
             A_FMUL,
             A_FDIV,

compiler/aarch64/ncpuinl.pas

@@ -44,6 +44,7 @@ interface
         procedure second_trunc_real; override;
         procedure second_get_frame; override;
         procedure second_fma; override;
+        procedure second_prefetch; override;
       private
         procedure load_fpu_location;
       end;
@@ -55,7 +56,7 @@ implementation
       globtype,verbose,globals,
       cpuinfo, defutil,symdef,aasmdata,aasmcpu,
       cgbase,cgutils,pass_1,pass_2,
-      ncal,
+      ncal,nutils,
       cpubase,ncgutil,cgobj,cgcpu, hlcgobj;
 
 {*****************************************************************************
@@ -272,6 +273,34 @@ implementation
       end;
 
 
+    procedure taarch64inlinenode.second_prefetch;
+      var
+        ref : treference;
+        r : tregister;
+        checkpointer_used : boolean;
+      begin
+        { do not call Checkpointer for left node }
+        checkpointer_used:=(cs_checkpointer in current_settings.localswitches);
+        if checkpointer_used then
+          node_change_local_switch(left,cs_checkpointer,false);
+        secondpass(left);
+        if checkpointer_used then
+          node_change_local_switch(left,cs_checkpointer,false);
+       case left.location.loc of
+         LOC_CREFERENCE,
+         LOC_REFERENCE:
+           begin
+             r:=cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
+             cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.location.reference,r);
+             reference_reset_base(ref,r,0,location.reference.temppos,left.location.reference.alignment,location.reference.volatility);
+             current_asmdata.CurrAsmList.concat(taicpu.op_const_ref(A_PRFM,0,ref));
+           end;
+         else
+           { nothing to prefetch };
+       end;
+      end;
+
+
 begin
   cinlinenode:=taarch64inlinenode;
 end.

compiler/arm/aoptcpu.pas

@@ -1284,504 +1284,512 @@ Implementation
 
       { All the optimisations from this point on require GetNextInstructionUsingReg
         to return True }
-      if not (
+      while (
         GetNextInstructionUsingReg(p, hpfar1, taicpu(p).oper[0]^.reg) and
         (hpfar1.typ = ait_instruction)
-      ) then
-        Exit;
+      ) do
+        begin
 
-      { Change the common
-        mov r0, r0, lsr #xxx
-        and r0, r0, #yyy/bic r0, r0, #xxx
+          { Change the common
+            mov r0, r0, lsr #xxx
+            and r0, r0, #yyy/bic r0, r0, #xxx
 
-        and remove the superfluous and/bic if possible
+            and remove the superfluous and/bic if possible
 
-        This could be extended to handle more cases.
-      }
+            This could be extended to handle more cases.
+          }
 
-      { Change
-        mov rx, ry, lsr/ror #xxx
-        uxtb/uxth rz,rx/and rz,rx,0xFF
-        dealloc rx
+          { Change
+            mov rx, ry, lsr/ror #xxx
+            uxtb/uxth rz,rx/and rz,rx,0xFF
+            dealloc rx
 
-        to
+            to
 
-        uxtb/uxth rz,ry,ror #xxx
-      }
-      if (GenerateThumb2Code) and
-         (taicpu(p).ops=3) and
-         (taicpu(p).oper[2]^.typ = top_shifterop) and
-         (taicpu(p).oper[2]^.shifterop^.rs = NR_NO) and
-         (taicpu(p).oper[2]^.shifterop^.shiftmode in [SM_LSR,SM_ROR]) and
-         RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) then
-         begin
-           if MatchInstruction(hpfar1, A_UXTB, [C_None], [PF_None]) and
-             (taicpu(hpfar1).ops = 2) and
-             (taicpu(p).oper[2]^.shifterop^.shiftimm in [8,16,24]) and
-             MatchOperand(taicpu(hpfar1).oper[1]^, taicpu(p).oper[0]^.reg) then
-             begin
-               taicpu(hpfar1).oper[1]^.reg := taicpu(p).oper[1]^.reg;
-               taicpu(hpfar1).loadshifterop(2,taicpu(p).oper[2]^.shifterop^);
-               taicpu(hpfar1).oper[2]^.shifterop^.shiftmode:=SM_ROR;
-               taicpu(hpfar1).ops := 3;
-
-               if not Assigned(hp1) then
-                 GetNextInstruction(p,hp1);
-
-               RemoveCurrentP(p, hp1);
-
-               result:=true;
-               exit;
-             end
-           else if MatchInstruction(hpfar1, A_UXTH, [C_None], [PF_None]) and
-             (taicpu(hpfar1).ops=2) and
-             (taicpu(p).oper[2]^.shifterop^.shiftimm in [16]) and
-             MatchOperand(taicpu(hpfar1).oper[1]^, taicpu(p).oper[0]^.reg) then
-             begin
-               taicpu(hpfar1).oper[1]^.reg := taicpu(p).oper[1]^.reg;
-               taicpu(hpfar1).loadshifterop(2,taicpu(p).oper[2]^.shifterop^);
-               taicpu(hpfar1).oper[2]^.shifterop^.shiftmode:=SM_ROR;
-               taicpu(hpfar1).ops := 3;
-
-               if not Assigned(hp1) then
-                 GetNextInstruction(p,hp1);
-
-               RemoveCurrentP(p, hp1);
-
-               result:=true;
-               exit;
-             end
-           else if MatchInstruction(hpfar1, A_AND, [C_None], [PF_None]) and
-             (taicpu(hpfar1).ops = 3) and
-             (taicpu(hpfar1).oper[2]^.typ = top_const) and
-             (taicpu(hpfar1).oper[2]^.val = $FF) and
-             (taicpu(p).oper[2]^.shifterop^.shiftimm in [8,16,24]) and
-             MatchOperand(taicpu(hpfar1).oper[1]^, taicpu(p).oper[0]^.reg) then
+            uxtb/uxth rz,ry,ror #xxx
+          }
+          if (GenerateThumb2Code) and
+             (taicpu(p).ops=3) and
+             (taicpu(p).oper[2]^.typ = top_shifterop) and
+             (taicpu(p).oper[2]^.shifterop^.rs = NR_NO) and
+             (taicpu(p).oper[2]^.shifterop^.shiftmode in [SM_LSR,SM_ROR]) and
+             RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) then
              begin
-               taicpu(hpfar1).ops := 3;
-               taicpu(hpfar1).opcode := A_UXTB;
-               taicpu(hpfar1).oper[1]^.reg := taicpu(p).oper[1]^.reg;
-               taicpu(hpfar1).loadshifterop(2,taicpu(p).oper[2]^.shifterop^);
-               taicpu(hpfar1).oper[2]^.shifterop^.shiftmode:=SM_ROR;
-
-               if not Assigned(hp1) then
-                 GetNextInstruction(p,hp1);
-
-               RemoveCurrentP(p, hp1);
-
-               result:=true;
-               exit;
+               if MatchInstruction(hpfar1, A_UXTB, [C_None], [PF_None]) and
+                 (taicpu(hpfar1).ops = 2) and
+                 (taicpu(p).oper[2]^.shifterop^.shiftimm in [8,16,24]) and
+                 MatchOperand(taicpu(hpfar1).oper[1]^, taicpu(p).oper[0]^.reg) then
+                 begin
+                   taicpu(hpfar1).oper[1]^.reg := taicpu(p).oper[1]^.reg;
+                   taicpu(hpfar1).loadshifterop(2,taicpu(p).oper[2]^.shifterop^);
+                   taicpu(hpfar1).oper[2]^.shifterop^.shiftmode:=SM_ROR;
+                   taicpu(hpfar1).ops := 3;
+
+                   if not Assigned(hp1) then
+                     GetNextInstruction(p,hp1);
+
+                   RemoveCurrentP(p, hp1);
+
+                   result:=true;
+                   exit;
+                 end
+               else if MatchInstruction(hpfar1, A_UXTH, [C_None], [PF_None]) and
+                 (taicpu(hpfar1).ops=2) and
+                 (taicpu(p).oper[2]^.shifterop^.shiftimm in [16]) and
+                 MatchOperand(taicpu(hpfar1).oper[1]^, taicpu(p).oper[0]^.reg) then
+                 begin
+                   taicpu(hpfar1).oper[1]^.reg := taicpu(p).oper[1]^.reg;
+                   taicpu(hpfar1).loadshifterop(2,taicpu(p).oper[2]^.shifterop^);
+                   taicpu(hpfar1).oper[2]^.shifterop^.shiftmode:=SM_ROR;
+                   taicpu(hpfar1).ops := 3;
+
+                   if not Assigned(hp1) then
+                     GetNextInstruction(p,hp1);
+
+                   RemoveCurrentP(p, hp1);
+
+                   result:=true;
+                   exit;
+                 end
+               else if MatchInstruction(hpfar1, A_AND, [C_None], [PF_None]) and
+                 (taicpu(hpfar1).ops = 3) and
+                 (taicpu(hpfar1).oper[2]^.typ = top_const) and
+                 (taicpu(hpfar1).oper[2]^.val = $FF) and
+                 (taicpu(p).oper[2]^.shifterop^.shiftimm in [8,16,24]) and
+                 MatchOperand(taicpu(hpfar1).oper[1]^, taicpu(p).oper[0]^.reg) then
+                 begin
+                   taicpu(hpfar1).ops := 3;
+                   taicpu(hpfar1).opcode := A_UXTB;
+                   taicpu(hpfar1).oper[1]^.reg := taicpu(p).oper[1]^.reg;
+                   taicpu(hpfar1).loadshifterop(2,taicpu(p).oper[2]^.shifterop^);
+                   taicpu(hpfar1).oper[2]^.shifterop^.shiftmode:=SM_ROR;
+
+                   if not Assigned(hp1) then
+                     GetNextInstruction(p,hp1);
+
+                   RemoveCurrentP(p, hp1);
+
+                   result:=true;
+                   exit;
+                 end;
              end;
-         end;
 
-      { 2-operald mov optimisations }
-      if (taicpu(p).ops = 2) then
-        begin
-          {
-            This removes the mul from
-            mov rX,0
-            ...
-            mul ...,rX,...
-          }
-          if (taicpu(p).oper[1]^.typ = top_const) then
+          { 2-operald mov optimisations }
+          if (taicpu(p).ops = 2) then
             begin
-(*          if false and
-            (taicpu(p).oper[1]^.val=0) and
-            MatchInstruction(hpfar1, [A_MUL,A_MLA], [taicpu(p).condition], [taicpu(p).oppostfix]) and
-            (((taicpu(hpfar1).oper[1]^.typ=top_reg) and MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[1]^)) or
-             ((taicpu(hpfar1).oper[2]^.typ=top_reg) and MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[2]^))) then
-              begin
-                TransferUsedRegs(TmpUsedRegs);
-                UpdateUsedRegs(TmpUsedRegs, tai(p.next));
-                UpdateUsedRegs(TmpUsedRegs, tai(hpfar1.next));
-                DebugMsg('Peephole Optimization: MovMUL/MLA2Mov0 done', p);
-                if taicpu(hpfar1).opcode=A_MUL then
-                  taicpu(hpfar1).loadconst(1,0)
-                else
-                  taicpu(hpfar1).loadreg(1,taicpu(hpfar1).oper[3]^.reg);
-                taicpu(hpfar1).ops:=2;
-                taicpu(hpfar1).opcode:=A_MOV;
-                if not(RegUsedAfterInstruction(taicpu(p).oper[0]^.reg,hpfar1,TmpUsedRegs)) then
-                  RemoveCurrentP(p);
-                Result:=true;
-                exit;
-              end
-          else*) if (taicpu(p).oper[1]^.val=0) and
-              MatchInstruction(hpfar1, A_MLA, [taicpu(p).condition], [taicpu(p).oppostfix]) and
-              MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[3]^) then
+              {
+                This removes the mul from
+                mov rX,0
+                ...
+                mul ...,rX,...
+              }
+              if (taicpu(p).oper[1]^.typ = top_const) then
                 begin
-                  TransferUsedRegs(TmpUsedRegs);
-                  UpdateUsedRegs(TmpUsedRegs, tai(p.next));
-                  UpdateUsedRegs(TmpUsedRegs, tai(hpfar1.next));
-                  DebugMsg('Peephole Optimization: MovMLA2MUL 1 done', p);
-                  taicpu(hpfar1).ops:=3;
-                  taicpu(hpfar1).opcode:=A_MUL;
-                  if not(RegUsedAfterInstruction(taicpu(p).oper[0]^.reg,hpfar1,TmpUsedRegs)) then
-                    begin
+    (*          if false and
+                (taicpu(p).oper[1]^.val=0) and
+                MatchInstruction(hpfar1, [A_MUL,A_MLA], [taicpu(p).condition], [taicpu(p).oppostfix]) and
+                (((taicpu(hpfar1).oper[1]^.typ=top_reg) and MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[1]^)) or
+                 ((taicpu(hpfar1).oper[2]^.typ=top_reg) and MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[2]^))) then
+                  begin
+                    TransferUsedRegs(TmpUsedRegs);
+                    UpdateUsedRegs(TmpUsedRegs, tai(p.next));
+                    UpdateUsedRegs(TmpUsedRegs, tai(hpfar1.next));
+                    DebugMsg('Peephole Optimization: MovMUL/MLA2Mov0 done', p);
+                    if taicpu(hpfar1).opcode=A_MUL then
+                      taicpu(hpfar1).loadconst(1,0)
+                    else
+                      taicpu(hpfar1).loadreg(1,taicpu(hpfar1).oper[3]^.reg);
+                    taicpu(hpfar1).ops:=2;
+                    taicpu(hpfar1).opcode:=A_MOV;
+                    if not(RegUsedAfterInstruction(taicpu(p).oper[0]^.reg,hpfar1,TmpUsedRegs)) then
                       RemoveCurrentP(p);
-                      Result:=true;
-                    end;
-                  exit;
-                end
-            {
-              This changes the very common
-              mov r0, #0
-              str r0, [...]
-              mov r0, #0
-              str r0, [...]
-
-              and removes all superfluous mov instructions
-            }
-            else if (taicpu(hpfar1).opcode=A_STR) then
-              begin
-                hp1 := hpfar1;
-                while MatchInstruction(hp1, A_STR, [taicpu(p).condition], []) and
-                      MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[0]^) and
-                      GetNextInstruction(hp1, hp2) and
-                      MatchInstruction(hp2, A_MOV, [taicpu(p).condition], [PF_None]) and
-                      (taicpu(hp2).ops = 2) and
-                      MatchOperand(taicpu(hp2).oper[0]^, taicpu(p).oper[0]^) and
-                      MatchOperand(taicpu(hp2).oper[1]^, taicpu(p).oper[1]^) do
+                    Result:=true;
+                    exit;
+                  end
+              else*) if (taicpu(p).oper[1]^.val=0) and
+                  MatchInstruction(hpfar1, A_MLA, [taicpu(p).condition], [taicpu(p).oppostfix]) and
+                  MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[3]^) then
+                    begin
+                      TransferUsedRegs(TmpUsedRegs);
+                      UpdateUsedRegs(TmpUsedRegs, tai(p.next));
+                      UpdateUsedRegs(TmpUsedRegs, tai(hpfar1.next));
+                      DebugMsg('Peephole Optimization: MovMLA2MUL 1 done', p);
+                      taicpu(hpfar1).ops:=3;
+                      taicpu(hpfar1).opcode:=A_MUL;
+                      if not(RegUsedAfterInstruction(taicpu(p).oper[0]^.reg,hpfar1,TmpUsedRegs)) then
+                        begin
+                          RemoveCurrentP(p);
+                          Result:=true;
+                        end;
+                      exit;
+                    end
+                {
+                  This changes the very common
+                  mov r0, #0
+                  str r0, [...]
+                  mov r0, #0
+                  str r0, [...]
+
+                  and removes all superfluous mov instructions
+                }
+                else if (taicpu(hpfar1).opcode=A_STR) then
                   begin
-                    DebugMsg('Peephole Optimization: MovStrMov done', hp2);
-                    GetNextInstruction(hp2,hp1);
-                    asml.remove(hp2);
-                    hp2.free;
-                    result:=true;
-                    if not assigned(hp1) then break;
-                  end;
+                    hp1 := hpfar1;
+                    while MatchInstruction(hp1, A_STR, [taicpu(p).condition], []) and
+                          MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[0]^) and
+                          GetNextInstruction(hp1, hp2) and
+                          MatchInstruction(hp2, A_MOV, [taicpu(p).condition], [PF_None]) and
+                          (taicpu(hp2).ops = 2) and
+                          MatchOperand(taicpu(hp2).oper[0]^, taicpu(p).oper[0]^) and
+                          MatchOperand(taicpu(hp2).oper[1]^, taicpu(p).oper[1]^) do
+                      begin
+                        DebugMsg('Peephole Optimization: MovStrMov done', hp2);
+                        GetNextInstruction(hp2,hp1);
+                        asml.remove(hp2);
+                        hp2.free;
+                        result:=true;
+                        if not assigned(hp1) then break;
+                      end;
 
-                if Result then
-                  Exit;
-              end;
-            end;
-          {
-            This removes the first mov from
-            mov rX,...
-            mov rX,...
-          }
-          if taicpu(hpfar1).opcode=A_MOV then
-            begin
-              hp1 := p;
-              while MatchInstruction(hpfar1, A_MOV, [taicpu(hp1).condition], [taicpu(hp1).oppostfix]) and
-                    (taicpu(hpfar1).ops = 2) and
-                    MatchOperand(taicpu(hp1).oper[0]^, taicpu(hpfar1).oper[0]^) and
-                    { don't remove the first mov if the second is a mov rX,rX }
-                    not(MatchOperand(taicpu(hpfar1).oper[0]^, taicpu(hpfar1).oper[1]^)) do
+                    if Result then
+                      Exit;
+                  end;
+                end;
+              {
+                This removes the first mov from
+                mov rX,...
+                mov rX,...
+              }
+              if taicpu(hpfar1).opcode=A_MOV then
                 begin
-                  { Defer removing the first p until after the while loop }
-                  if p <> hp1 then
+                  hp1 := p;
+                  while MatchInstruction(hpfar1, A_MOV, [taicpu(hp1).condition], [taicpu(hp1).oppostfix]) and
+                        (taicpu(hpfar1).ops = 2) and
+                        MatchOperand(taicpu(hp1).oper[0]^, taicpu(hpfar1).oper[0]^) and
+                        { don't remove the first mov if the second is a mov rX,rX }
+                        not(MatchOperand(taicpu(hpfar1).oper[0]^, taicpu(hpfar1).oper[1]^)) do
                     begin
-                      DebugMsg('Peephole Optimization: MovMov done', hp1);
-                      asml.remove(hp1);
-                      hp1.free;
+                      { Defer removing the first p until after the while loop }
+                      if p <> hp1 then
+                        begin
+                          DebugMsg('Peephole Optimization: MovMov done', hp1);
+                          asml.remove(hp1);
+                          hp1.free;
+                        end;
+                      hp1:=hpfar1;
+                      GetNextInstruction(hpfar1,hpfar1);
+                      result:=true;
+                      if not assigned(hpfar1) then
+                        Break;
+                    end;
+
+                  if Result then
+                    begin
+                      DebugMsg('Peephole Optimization: MovMov done', p);
+                      RemoveCurrentp(p);
+                      Exit;
                     end;
-                  hp1:=hpfar1;
-                  GetNextInstruction(hpfar1,hpfar1);
-                  result:=true;
-                  if not assigned(hpfar1) then
-                    Break;
                 end;
 
-              if Result then
+              if RedundantMovProcess(p,hpfar1) then
                 begin
-                  DebugMsg('Peephole Optimization: MovMov done', p);
-                  RemoveCurrentp(p);
-                  Exit;
+                  Result:=true;
+                  { p might not point at a mov anymore }
+                  exit;
                 end;
-            end;
 
-          if RedundantMovProcess(p,hpfar1) then
-            begin
-              Result:=true;
-              { p might not point at a mov anymore }
-              exit;
-            end;
+              { If hpfar1 is nil after the call to RedundantMovProcess, it is
+                because it would have become a dangling pointer, so reinitialise it. }
+              if not Assigned(hpfar1) then
+                Continue;
 
-          { Fold the very common sequence
-              mov  regA, regB
-              ldr* regA, [regA]
-            to
-              ldr* regA, [regB]
-            CAUTION! If this one is successful p might not be a mov instruction anymore!
-          }
-          if
-             // Make sure that Thumb code doesn't propagate a high register into a reference
-             (
-               (
-                 GenerateThumbCode and
-                 (getsupreg(taicpu(p).oper[1]^.reg) < RS_R8)
-               ) or (not GenerateThumbCode)
-             ) and
-             (taicpu(p).oper[1]^.typ = top_reg) and
-             (taicpu(p).oppostfix = PF_NONE) and
-             MatchInstruction(hpfar1, [A_LDR, A_STR], [taicpu(p).condition], []) and
-             (taicpu(hpfar1).oper[1]^.typ = top_ref) and
-             { We can change the base register only when the instruction uses AM_OFFSET }
-             ((taicpu(hpfar1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg) or
-               ((taicpu(hpfar1).oper[1]^.ref^.addressmode = AM_OFFSET) and
-                (taicpu(hpfar1).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg))
-             ) and
-             not(RegModifiedBetween(taicpu(p).oper[1]^.reg,p,hpfar1)) and
-             RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) then
-            begin
-              DebugMsg('Peephole Optimization: MovLdr2Ldr done', hpfar1);
-              if (taicpu(hpfar1).oper[1]^.ref^.addressmode = AM_OFFSET) and
-                 (taicpu(hpfar1).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg) then
-                taicpu(hpfar1).oper[1]^.ref^.base := taicpu(p).oper[1]^.reg;
-
-              if taicpu(hpfar1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg then
-                taicpu(hpfar1).oper[1]^.ref^.index := taicpu(p).oper[1]^.reg;
-
-              dealloc:=FindRegDeAlloc(taicpu(p).oper[1]^.reg, tai(p.Next));
-              if Assigned(dealloc) then
+              { Fold the very common sequence
+                  mov  regA, regB
+                  ldr* regA, [regA]
+                to
+                  ldr* regA, [regB]
+                CAUTION! If this one is successful p might not be a mov instruction anymore!
+              }
+              if
+                 // Make sure that Thumb code doesn't propagate a high register into a reference
+                 (
+                   (
+                     GenerateThumbCode and
+                     (getsupreg(taicpu(p).oper[1]^.reg) < RS_R8)
+                   ) or (not GenerateThumbCode)
+                 ) and
+                 (taicpu(p).oper[1]^.typ = top_reg) and
+                 (taicpu(p).oppostfix = PF_NONE) and
+                 MatchInstruction(hpfar1, [A_LDR, A_STR], [taicpu(p).condition], []) and
+                 (taicpu(hpfar1).oper[1]^.typ = top_ref) and
+                 { We can change the base register only when the instruction uses AM_OFFSET }
+                 ((taicpu(hpfar1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg) or
+                   ((taicpu(hpfar1).oper[1]^.ref^.addressmode = AM_OFFSET) and
+                    (taicpu(hpfar1).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg))
+                 ) and
+                 not(RegModifiedBetween(taicpu(p).oper[1]^.reg,p,hpfar1)) and
+                 RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) then
                 begin
-                  asml.remove(dealloc);
-                  asml.InsertAfter(dealloc,hpfar1);
-                end;
+                  DebugMsg('Peephole Optimization: MovLdr2Ldr done', hpfar1);
+                  if (taicpu(hpfar1).oper[1]^.ref^.addressmode = AM_OFFSET) and
+                     (taicpu(hpfar1).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg) then
+                    taicpu(hpfar1).oper[1]^.ref^.base := taicpu(p).oper[1]^.reg;
 
-              if not Assigned(hp1) then
-                GetNextInstruction(p, hp1);
+                  if taicpu(hpfar1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg then
+                    taicpu(hpfar1).oper[1]^.ref^.index := taicpu(p).oper[1]^.reg;
 
-              RemoveCurrentP(p, hp1);
+                  dealloc:=FindRegDeAlloc(taicpu(p).oper[1]^.reg, tai(p.Next));
+                  if Assigned(dealloc) then
+                    begin
+                      asml.remove(dealloc);
+                      asml.InsertAfter(dealloc,hpfar1);
+                    end;
 
-              result:=true;
-              Exit;
-            end
-        end
+                  if not Assigned(hp1) then
+                    GetNextInstruction(p, hp1);
 
-      { 3-operald mov optimisations }
-      else if (taicpu(p).ops = 3) then
-        begin
+                  RemoveCurrentP(p, hp1);
 
-          if (taicpu(p).oper[2]^.typ = top_shifterop) and
-            (taicpu(p).oper[2]^.shifterop^.rs = NR_NO) and
-            (taicpu(p).oper[2]^.shifterop^.shiftmode = SM_LSR) and
-            (taicpu(hpfar1).ops>=1) and
-            (taicpu(hpfar1).oper[0]^.typ=top_reg) and
-            (not RegModifiedBetween(taicpu(hpfar1).oper[0]^.reg, p, hpfar1)) and
-            RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) then
-            begin
-              if (taicpu(p).oper[2]^.shifterop^.shiftimm >= 24 ) and
-                MatchInstruction(hpfar1, A_AND, [taicpu(p).condition], [taicpu(p).oppostfix]) and
-                (taicpu(hpfar1).ops=3) and
-                MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[1]^) and
-                (taicpu(hpfar1).oper[2]^.typ = top_const) and
-                { Check if the AND actually would only mask out bits being already zero because of the shift
-                }
-                ((($ffffffff shr taicpu(p).oper[2]^.shifterop^.shiftimm) and taicpu(hpfar1).oper[2]^.val) =
-                  ($ffffffff shr taicpu(p).oper[2]^.shifterop^.shiftimm)) then
-                begin
-                  DebugMsg('Peephole Optimization: LsrAnd2Lsr done', hpfar1);
-                  taicpu(p).oper[0]^.reg:=taicpu(hpfar1).oper[0]^.reg;
-                  asml.remove(hpfar1);
-                  hpfar1.free;
                   result:=true;
                   Exit;
                 end
-              else if MatchInstruction(hpfar1, A_BIC, [taicpu(p).condition], [taicpu(p).oppostfix]) and
-                (taicpu(hpfar1).ops=3) and
-                MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[1]^) and
-                (taicpu(hpfar1).oper[2]^.typ = top_const) and
-                { Check if the BIC actually would only mask out bits beeing already zero because of the shift }
-                (taicpu(hpfar1).oper[2]^.val<>0) and
-                (BsfDWord(taicpu(hpfar1).oper[2]^.val)>=32-taicpu(p).oper[2]^.shifterop^.shiftimm) then
-                begin
-                  DebugMsg('Peephole Optimization: LsrBic2Lsr done', hpfar1);
-                  taicpu(p).oper[0]^.reg:=taicpu(hpfar1).oper[0]^.reg;
-                  asml.remove(hpfar1);
-                  hpfar1.free;
-                  result:=true;
-                  Exit;
-                end;
-            end;
-          { This folds shifterops into following instructions
-            mov r0, r1, lsl #8
-            add r2, r3, r0
+            end
 
-            to
+          { 3-operald mov optimisations }
+          else if (taicpu(p).ops = 3) then
+            begin
 
-            add r2, r3, r1, lsl #8
-            CAUTION! If this one is successful p might not be a mov instruction anymore!
-          }
-          if (taicpu(p).oper[1]^.typ = top_reg) and
-           (taicpu(p).oper[2]^.typ = top_shifterop) and
-           (taicpu(p).oppostfix = PF_NONE) and
-           MatchInstruction(hpfar1, [A_ADD, A_ADC, A_RSB, A_RSC, A_SUB, A_SBC,
-                                  A_AND, A_BIC, A_EOR, A_ORR, A_TEQ, A_TST,
-                                  A_CMP, A_CMN],
-                            [taicpu(p).condition], [PF_None]) and
-           (not ((GenerateThumb2Code) and
-                 (taicpu(hpfar1).opcode in [A_SBC]) and
-                 (((taicpu(hpfar1).ops=3) and
-                   MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[1]^.reg)) or
-                  ((taicpu(hpfar1).ops=2) and
-                   MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[0]^.reg))))) and
-           RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) and
-           (taicpu(hpfar1).ops >= 2) and
-           {Currently we can't fold into another shifterop}
-           (taicpu(hpfar1).oper[taicpu(hpfar1).ops-1]^.typ = top_reg) and
-           {Folding rrx is problematic because of the C-Flag, as we currently can't check
-            NR_DEFAULTFLAGS for modification}
-           (
-             {Everything is fine if we don't use RRX}
-             (taicpu(p).oper[2]^.shifterop^.shiftmode <> SM_RRX) or
-             (
-               {If it is RRX, then check if we're just accessing the next instruction}
-               Assigned(hp1) and
-               (hpfar1 = hp1)
-             )
-           ) and
-           { reg1 might not be modified inbetween }
-           not(RegModifiedBetween(taicpu(p).oper[1]^.reg,p,hpfar1)) and
-           { The shifterop can contain a register, might not be modified}
-           (
-             (taicpu(p).oper[2]^.shifterop^.rs = NR_NO) or
-             not(RegModifiedBetween(taicpu(p).oper[2]^.shifterop^.rs, p, hpfar1))
-           ) and
-           (
-             {Only ONE of the two src operands is allowed to match}
-             MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[taicpu(hpfar1).ops-2]^) xor
-             MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[taicpu(hpfar1).ops-1]^)
-           ) then
-          begin
-            if taicpu(hpfar1).opcode in [A_TST, A_TEQ, A_CMN] then
-              I2:=0
-            else
-              I2:=1;
-            for I:=I2 to taicpu(hpfar1).ops-1 do
-              if MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[I]^.reg) then
+              if (taicpu(p).oper[2]^.typ = top_shifterop) and
+                (taicpu(p).oper[2]^.shifterop^.rs = NR_NO) and
+                (taicpu(p).oper[2]^.shifterop^.shiftmode = SM_LSR) and
+                (taicpu(hpfar1).ops>=1) and
+                (taicpu(hpfar1).oper[0]^.typ=top_reg) and
+                (not RegModifiedBetween(taicpu(hpfar1).oper[0]^.reg, p, hpfar1)) and
+                RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) then
                 begin
-                  { If the parameter matched on the second op from the RIGHT
-                    we have to switch the parameters, this will not happen for CMP
-                    were we're only evaluating the most right parameter
-                  }
-                  if I <> taicpu(hpfar1).ops-1 then
+                  if (taicpu(p).oper[2]^.shifterop^.shiftimm >= 24 ) and
+                    MatchInstruction(hpfar1, A_AND, [taicpu(p).condition], [taicpu(p).oppostfix]) and
+                    (taicpu(hpfar1).ops=3) and
+                    MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[1]^) and
+                    (taicpu(hpfar1).oper[2]^.typ = top_const) and
+                    { Check if the AND actually would only mask out bits being already zero because of the shift
+                    }
+                    ((($ffffffff shr taicpu(p).oper[2]^.shifterop^.shiftimm) and taicpu(hpfar1).oper[2]^.val) =
+                      ($ffffffff shr taicpu(p).oper[2]^.shifterop^.shiftimm)) then
                     begin
-                      {The SUB operators need to be changed when we swap parameters}
-                      case taicpu(hpfar1).opcode of
-                        A_SUB: tempop:=A_RSB;
-                        A_SBC: tempop:=A_RSC;
-                        A_RSB: tempop:=A_SUB;
-                        A_RSC: tempop:=A_SBC;
-                        else tempop:=taicpu(hpfar1).opcode;
-                      end;
-                      if taicpu(hpfar1).ops = 3 then
-                        hp2:=taicpu.op_reg_reg_reg_shifterop(tempop,
-                             taicpu(hpfar1).oper[0]^.reg, taicpu(hpfar1).oper[2]^.reg,
-                             taicpu(p).oper[1]^.reg, taicpu(p).oper[2]^.shifterop^)
-                      else
-                        hp2:=taicpu.op_reg_reg_shifterop(tempop,
-                             taicpu(hpfar1).oper[0]^.reg, taicpu(p).oper[1]^.reg,
-                             taicpu(p).oper[2]^.shifterop^);
+                      DebugMsg('Peephole Optimization: LsrAnd2Lsr done', hpfar1);
+                      taicpu(p).oper[0]^.reg:=taicpu(hpfar1).oper[0]^.reg;
+                      asml.remove(hpfar1);
+                      hpfar1.free;
+                      result:=true;
+                      Exit;
                     end
-                  else
-                    if taicpu(hpfar1).ops = 3 then
-                      hp2:=taicpu.op_reg_reg_reg_shifterop(taicpu(hpfar1).opcode,
-                           taicpu(hpfar1).oper[0]^.reg, taicpu(hpfar1).oper[1]^.reg,
-                           taicpu(p).oper[1]^.reg, taicpu(p).oper[2]^.shifterop^)
-                    else
-                      hp2:=taicpu.op_reg_reg_shifterop(taicpu(hpfar1).opcode,
-                           taicpu(hpfar1).oper[0]^.reg, taicpu(p).oper[1]^.reg,
-                           taicpu(p).oper[2]^.shifterop^);
-                  if taicpu(p).oper[2]^.shifterop^.rs<>NR_NO then
-                    AllocRegBetween(taicpu(p).oper[2]^.shifterop^.rs,p,hpfar1,UsedRegs);
-                  AllocRegBetween(taicpu(p).oper[1]^.reg,p,hpfar1,UsedRegs);
-                  asml.insertbefore(hp2, hpfar1);
-                  asml.remove(hpfar1);
-                  hpfar1.free;
-                  DebugMsg('Peephole Optimization: FoldShiftProcess done', hp2);
+                  else if MatchInstruction(hpfar1, A_BIC, [taicpu(p).condition], [taicpu(p).oppostfix]) and
+                    (taicpu(hpfar1).ops=3) and
+                    MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[1]^) and
+                    (taicpu(hpfar1).oper[2]^.typ = top_const) and
+                    { Check if the BIC actually would only mask out bits beeing already zero because of the shift }
+                    (taicpu(hpfar1).oper[2]^.val<>0) and
+                    (BsfDWord(taicpu(hpfar1).oper[2]^.val)>=32-taicpu(p).oper[2]^.shifterop^.shiftimm) then
+                    begin
+                      DebugMsg('Peephole Optimization: LsrBic2Lsr done', hpfar1);
+                      taicpu(p).oper[0]^.reg:=taicpu(hpfar1).oper[0]^.reg;
+                      asml.remove(hpfar1);
+                      hpfar1.free;
+                      result:=true;
+                      Exit;
+                    end;
+                end;
+              { This folds shifterops into following instructions
+                mov r0, r1, lsl #8
+                add r2, r3, r0
 
-                  if not Assigned(hp1) then
-                    GetNextInstruction(p, hp1)
-                  else if hp1 = hpfar1 then
-                    { If hp1 = hpfar1, then it's a dangling pointer }
-                    hp1 := hp2;
+                to
 
-                  RemoveCurrentP(p, hp1);
-                  Result:=true;
-                  Exit;
-                end;
-          end;
-        {
-          Fold
-            mov r1, r1, lsl #2
-            ldr/ldrb r0, [r0, r1]
-          to
-            ldr/ldrb r0, [r0, r1, lsl #2]
-
-          XXX: This still needs some work, as we quite often encounter something like
-                 mov r1, r2, lsl #2
-                 add r2, r3, #imm
-                 ldr r0, [r2, r1]
-               which can't be folded because r2 is overwritten between the shift and the ldr.
-               We could try to shuffle the registers around and fold it into.
-                 add r1, r3, #imm
-                 ldr r0, [r1, r2, lsl #2]
-        }
-        if (not(GenerateThumbCode)) and
-          { thumb2 allows only lsl #0..#3 }
-          (not(GenerateThumb2Code) or
-           ((taicpu(p).oper[2]^.shifterop^.shiftimm in [0..3]) and
-            (taicpu(p).oper[2]^.shifterop^.shiftmode=SM_LSL)
-           )
-          ) and
-           (taicpu(p).oper[1]^.typ = top_reg) and
-           (taicpu(p).oper[2]^.typ = top_shifterop) and
-           { RRX is tough to handle, because it requires tracking the C-Flag,
-             it is also extremly unlikely to be emitted this way}
-           (taicpu(p).oper[2]^.shifterop^.shiftmode <> SM_RRX) and
-           (taicpu(p).oper[2]^.shifterop^.shiftimm <> 0) and
-           (taicpu(p).oppostfix = PF_NONE) and
-           {Only LDR, LDRB, STR, STRB can handle scaled register indexing}
-           (MatchInstruction(hpfar1, [A_LDR, A_STR], [taicpu(p).condition], [PF_None, PF_B]) or
-            (GenerateThumb2Code and
-             MatchInstruction(hpfar1, [A_LDR, A_STR], [taicpu(p).condition], [PF_None, PF_B, PF_SB, PF_H, PF_SH]))
-           ) and
-           (
-             {If this is address by offset, one of the two registers can be used}
-             ((taicpu(hpfar1).oper[1]^.ref^.addressmode=AM_OFFSET) and
+                add r2, r3, r1, lsl #8
+                CAUTION! If this one is successful p might not be a mov instruction anymore!
+              }
+              if (taicpu(p).oper[1]^.typ = top_reg) and
+               (taicpu(p).oper[2]^.typ = top_shifterop) and
+               (taicpu(p).oppostfix = PF_NONE) and
+               MatchInstruction(hpfar1, [A_ADD, A_ADC, A_RSB, A_RSC, A_SUB, A_SBC,
+                                      A_AND, A_BIC, A_EOR, A_ORR, A_TEQ, A_TST,
+                                      A_CMP, A_CMN],
+                                [taicpu(p).condition], [PF_None]) and
+               (not ((GenerateThumb2Code) and
+                     (taicpu(hpfar1).opcode in [A_SBC]) and
+                     (((taicpu(hpfar1).ops=3) and
+                       MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[1]^.reg)) or
+                      ((taicpu(hpfar1).ops=2) and
+                       MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[0]^.reg))))) and
+               RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) and
+               (taicpu(hpfar1).ops >= 2) and
+               {Currently we can't fold into another shifterop}
+               (taicpu(hpfar1).oper[taicpu(hpfar1).ops-1]^.typ = top_reg) and
+               {Folding rrx is problematic because of the C-Flag, as we currently can't check
+                NR_DEFAULTFLAGS for modification}
+               (
+                 {Everything is fine if we don't use RRX}
+                 (taicpu(p).oper[2]^.shifterop^.shiftmode <> SM_RRX) or
+                 (
+                   {If it is RRX, then check if we're just accessing the next instruction}
+                   Assigned(hp1) and
+                   (hpfar1 = hp1)
+                 )
+               ) and
+               { reg1 might not be modified inbetween }
+               not(RegModifiedBetween(taicpu(p).oper[1]^.reg,p,hpfar1)) and
+               { The shifterop can contain a register, might not be modified}
+               (
+                 (taicpu(p).oper[2]^.shifterop^.rs = NR_NO) or
+                 not(RegModifiedBetween(taicpu(p).oper[2]^.shifterop^.rs, p, hpfar1))
+               ) and
                (
-                 (taicpu(hpfar1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg) xor
-                 (taicpu(hpfar1).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg)
+                 {Only ONE of the two src operands is allowed to match}
+                 MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[taicpu(hpfar1).ops-2]^) xor
+                 MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[taicpu(hpfar1).ops-1]^)
+               ) then
+              begin
+                if taicpu(hpfar1).opcode in [A_TST, A_TEQ, A_CMN] then
+                  I2:=0
+                else
+                  I2:=1;
+                for I:=I2 to taicpu(hpfar1).ops-1 do
+                  if MatchOperand(taicpu(p).oper[0]^, taicpu(hpfar1).oper[I]^.reg) then
+                    begin
+                      { If the parameter matched on the second op from the RIGHT
+                        we have to switch the parameters, this will not happen for CMP
+                        were we're only evaluating the most right parameter
+                      }
+                      if I <> taicpu(hpfar1).ops-1 then
+                        begin
+                          {The SUB operators need to be changed when we swap parameters}
+                          case taicpu(hpfar1).opcode of
+                            A_SUB: tempop:=A_RSB;
+                            A_SBC: tempop:=A_RSC;
+                            A_RSB: tempop:=A_SUB;
+                            A_RSC: tempop:=A_SBC;
+                            else tempop:=taicpu(hpfar1).opcode;
+                          end;
+                          if taicpu(hpfar1).ops = 3 then
+                            hp2:=taicpu.op_reg_reg_reg_shifterop(tempop,
+                                 taicpu(hpfar1).oper[0]^.reg, taicpu(hpfar1).oper[2]^.reg,
+                                 taicpu(p).oper[1]^.reg, taicpu(p).oper[2]^.shifterop^)
+                          else
+                            hp2:=taicpu.op_reg_reg_shifterop(tempop,
+                                 taicpu(hpfar1).oper[0]^.reg, taicpu(p).oper[1]^.reg,
+                                 taicpu(p).oper[2]^.shifterop^);
+                        end
+                      else
+                        if taicpu(hpfar1).ops = 3 then
+                          hp2:=taicpu.op_reg_reg_reg_shifterop(taicpu(hpfar1).opcode,
+                               taicpu(hpfar1).oper[0]^.reg, taicpu(hpfar1).oper[1]^.reg,
+                               taicpu(p).oper[1]^.reg, taicpu(p).oper[2]^.shifterop^)
+                        else
+                          hp2:=taicpu.op_reg_reg_shifterop(taicpu(hpfar1).opcode,
+                               taicpu(hpfar1).oper[0]^.reg, taicpu(p).oper[1]^.reg,
+                               taicpu(p).oper[2]^.shifterop^);
+                      if taicpu(p).oper[2]^.shifterop^.rs<>NR_NO then
+                        AllocRegBetween(taicpu(p).oper[2]^.shifterop^.rs,p,hpfar1,UsedRegs);
+                      AllocRegBetween(taicpu(p).oper[1]^.reg,p,hpfar1,UsedRegs);
+                      asml.insertbefore(hp2, hpfar1);
+                      asml.remove(hpfar1);
+                      hpfar1.free;
+                      DebugMsg('Peephole Optimization: FoldShiftProcess done', hp2);
+
+                      if not Assigned(hp1) then
+                        GetNextInstruction(p, hp1)
+                      else if hp1 = hpfar1 then
+                        { If hp1 = hpfar1, then it's a dangling pointer }
+                        hp1 := hp2;
+
+                      RemoveCurrentP(p, hp1);
+                      Result:=true;
+                      Exit;
+                    end;
+              end;
+            {
+              Fold
+                mov r1, r1, lsl #2
+                ldr/ldrb r0, [r0, r1]
+              to
+                ldr/ldrb r0, [r0, r1, lsl #2]
+
+              XXX: This still needs some work, as we quite often encounter something like
+                     mov r1, r2, lsl #2
+                     add r2, r3, #imm
+                     ldr r0, [r2, r1]
+                   which can't be folded because r2 is overwritten between the shift and the ldr.
+                   We could try to shuffle the registers around and fold it into.
+                     add r1, r3, #imm
+                     ldr r0, [r1, r2, lsl #2]
+            }
+            if (not(GenerateThumbCode)) and
+              { thumb2 allows only lsl #0..#3 }
+              (not(GenerateThumb2Code) or
+               ((taicpu(p).oper[2]^.shifterop^.shiftimm in [0..3]) and
+                (taicpu(p).oper[2]^.shifterop^.shiftmode=SM_LSL)
                )
-             ) or
-             {For post and preindexed only the index register can be used}
-             ((taicpu(hpfar1).oper[1]^.ref^.addressmode in [AM_POSTINDEXED, AM_PREINDEXED]) and
+              ) and
+               (taicpu(p).oper[1]^.typ = top_reg) and
+               (taicpu(p).oper[2]^.typ = top_shifterop) and
+               { RRX is tough to handle, because it requires tracking the C-Flag,
+                 it is also extremly unlikely to be emitted this way}
+               (taicpu(p).oper[2]^.shifterop^.shiftmode <> SM_RRX) and
+               (taicpu(p).oper[2]^.shifterop^.shiftimm <> 0) and
+               (taicpu(p).oppostfix = PF_NONE) and
+               {Only LDR, LDRB, STR, STRB can handle scaled register indexing}
+               (MatchInstruction(hpfar1, [A_LDR, A_STR], [taicpu(p).condition], [PF_None, PF_B]) or
+                (GenerateThumb2Code and
+                 MatchInstruction(hpfar1, [A_LDR, A_STR], [taicpu(p).condition], [PF_None, PF_B, PF_SB, PF_H, PF_SH]))
+               ) and
                (
-                 (taicpu(hpfar1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg) and
-                 (taicpu(hpfar1).oper[1]^.ref^.base <> taicpu(p).oper[0]^.reg)
+                 {If this is address by offset, one of the two registers can be used}
+                 ((taicpu(hpfar1).oper[1]^.ref^.addressmode=AM_OFFSET) and
+                   (
+                     (taicpu(hpfar1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg) xor
+                     (taicpu(hpfar1).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg)
+                   )
+                 ) or
+                 {For post and preindexed only the index register can be used}
+                 ((taicpu(hpfar1).oper[1]^.ref^.addressmode in [AM_POSTINDEXED, AM_PREINDEXED]) and
+                   (
+                     (taicpu(hpfar1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg) and
+                     (taicpu(hpfar1).oper[1]^.ref^.base <> taicpu(p).oper[0]^.reg)
+                   ) and
+                   (not GenerateThumb2Code)
+                 )
                ) and
-               (not GenerateThumb2Code)
-             )
-           ) and
-           { Only fold if both registers are used. Otherwise we are folding p with itself }
-           (taicpu(hpfar1).oper[1]^.ref^.index<>NR_NO) and
-           (taicpu(hpfar1).oper[1]^.ref^.base<>NR_NO) and
-           { Only fold if there isn't another shifterop already, and offset is zero. }
-           (taicpu(hpfar1).oper[1]^.ref^.offset = 0) and
-           (taicpu(hpfar1).oper[1]^.ref^.shiftmode = SM_None) and
-           not(RegModifiedBetween(taicpu(p).oper[1]^.reg,p,hpfar1)) and
-           RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) then
-           begin
-             { If the register we want to do the shift for resides in base, we need to swap that}
-             if (taicpu(hpfar1).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg) then
-               taicpu(hpfar1).oper[1]^.ref^.base := taicpu(hpfar1).oper[1]^.ref^.index;
-             taicpu(hpfar1).oper[1]^.ref^.index := taicpu(p).oper[1]^.reg;
-             taicpu(hpfar1).oper[1]^.ref^.shiftmode := taicpu(p).oper[2]^.shifterop^.shiftmode;
-             taicpu(hpfar1).oper[1]^.ref^.shiftimm := taicpu(p).oper[2]^.shifterop^.shiftimm;
-             DebugMsg('Peephole Optimization: FoldShiftLdrStr done', hpfar1);
-             RemoveCurrentP(p);
-             Result:=true;
-             Exit;
-           end;
+               { Only fold if both registers are used. Otherwise we are folding p with itself }
+               (taicpu(hpfar1).oper[1]^.ref^.index<>NR_NO) and
+               (taicpu(hpfar1).oper[1]^.ref^.base<>NR_NO) and
+               { Only fold if there isn't another shifterop already, and offset is zero. }
+               (taicpu(hpfar1).oper[1]^.ref^.offset = 0) and
+               (taicpu(hpfar1).oper[1]^.ref^.shiftmode = SM_None) and
+               not(RegModifiedBetween(taicpu(p).oper[1]^.reg,p,hpfar1)) and
+               RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hpfar1)) then
+               begin
+                 { If the register we want to do the shift for resides in base, we need to swap that}
+                 if (taicpu(hpfar1).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg) then
+                   taicpu(hpfar1).oper[1]^.ref^.base := taicpu(hpfar1).oper[1]^.ref^.index;
+                 taicpu(hpfar1).oper[1]^.ref^.index := taicpu(p).oper[1]^.reg;
+                 taicpu(hpfar1).oper[1]^.ref^.shiftmode := taicpu(p).oper[2]^.shifterop^.shiftmode;
+                 taicpu(hpfar1).oper[1]^.ref^.shiftimm := taicpu(p).oper[2]^.shifterop^.shiftimm;
+                 DebugMsg('Peephole Optimization: FoldShiftLdrStr done', hpfar1);
+                 RemoveCurrentP(p);
+                 Result:=true;
+                 Exit;
+               end;
+            end;
+          {
+            Often we see shifts and then a superfluous mov to another register
+            In the future this might be handled in RedundantMovProcess when it uses RegisterTracking
+          }
+          if RemoveSuperfluousMove(p, hpfar1, 'MovMov2Mov') then
+            Result:=true;
+
+          Exit;
         end;
-      {
-        Often we see shifts and then a superfluous mov to another register
-        In the future this might be handled in RedundantMovProcess when it uses RegisterTracking
-      }
-      if RemoveSuperfluousMove(p, hpfar1, 'MovMov2Mov') then
-        Result:=true;
     end;
 
 

compiler/armgen/aoptarm.pas

@@ -40,7 +40,7 @@ Type
     procedure DebugMsg(const s : string; p : tai);
 
     function RemoveSuperfluousMove(const p: tai; movp: tai; const optimizer: string): boolean;
-    function RedundantMovProcess(var p: tai; hp1: tai): boolean;
+    function RedundantMovProcess(var p: tai; var hp1: tai): boolean;
     function GetNextInstructionUsingReg(Current: tai; out Next: tai; reg: TRegister): Boolean;
 
     function OptPass1UXTB(var p: tai): Boolean;
@@ -292,10 +292,10 @@ Implementation
     end;
 
 
-  function TARMAsmOptimizer.RedundantMovProcess(var p: tai;hp1: tai):boolean;
+  function TARMAsmOptimizer.RedundantMovProcess(var p: tai; var hp1: tai):boolean;
     var
       I: Integer;
-      current_hp: tai;
+      current_hp, next_hp: tai;
       LDRChange: Boolean;
     begin
       Result:=false;
@@ -390,80 +390,80 @@ Implementation
               TransferUsedRegs(TmpUsedRegs);
 
               { Search local instruction block }
-              while GetNextInstruction(current_hp, hp1) and (hp1 <> BlockEnd) and (hp1.typ = ait_instruction) do
+              while GetNextInstruction(current_hp, next_hp) and (next_hp <> BlockEnd) and (next_hp.typ = ait_instruction) do
                 begin
                   UpdateUsedRegs(TmpUsedRegs, tai(current_hp.Next));
                   LDRChange := False;
 
-                  if (taicpu(hp1).opcode in [A_LDR,A_STR]) and (taicpu(hp1).ops = 2) then
+                  if (taicpu(next_hp).opcode in [A_LDR,A_STR]) and (taicpu(next_hp).ops = 2) then
                     begin
 
                       { Change the registers from r1 to r0 }
-                      if (taicpu(hp1).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg) and
+                      if (taicpu(next_hp).oper[1]^.ref^.base = taicpu(p).oper[0]^.reg) and
 {$ifdef ARM}
                         { This optimisation conflicts with something and raises
                           an access violation - needs further investigation. [Kit] }
-                        (taicpu(hp1).opcode <> A_LDR) and
+                        (taicpu(next_hp).opcode <> A_LDR) and
 {$endif ARM}
                         { Don't mess around with the base register if the
                           reference is pre- or post-indexed }
-                        (taicpu(hp1).oper[1]^.ref^.addressmode = AM_OFFSET) then
+                        (taicpu(next_hp).oper[1]^.ref^.addressmode = AM_OFFSET) then
                         begin
-                          taicpu(hp1).oper[1]^.ref^.base := taicpu(p).oper[1]^.reg;
+                          taicpu(next_hp).oper[1]^.ref^.base := taicpu(p).oper[1]^.reg;
                           LDRChange := True;
                         end;
 
-                      if taicpu(hp1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg then
+                      if taicpu(next_hp).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg then
                         begin
-                          taicpu(hp1).oper[1]^.ref^.index := taicpu(p).oper[1]^.reg;
+                          taicpu(next_hp).oper[1]^.ref^.index := taicpu(p).oper[1]^.reg;
                           LDRChange := True;
                         end;
 
                       if LDRChange then
-                        DebugMsg('Peephole Optimization: ' + std_regname(taicpu(p).oper[0]^.reg) + ' = ' + std_regname(taicpu(p).oper[1]^.reg) + ' (MovLdr2Ldr 1)', hp1);
+                        DebugMsg('Peephole Optimization: ' + std_regname(taicpu(p).oper[0]^.reg) + ' = ' + std_regname(taicpu(p).oper[1]^.reg) + ' (MovLdr2Ldr 1)', next_hp);
 
                       { Drop out if we're dealing with pre-indexed references }
-                      if (taicpu(hp1).oper[1]^.ref^.addressmode = AM_PREINDEXED) and
+                      if (taicpu(next_hp).oper[1]^.ref^.addressmode = AM_PREINDEXED) and
                         (
-                          RegInRef(taicpu(p).oper[0]^.reg, taicpu(hp1).oper[1]^.ref^) or
-                          RegInRef(taicpu(p).oper[1]^.reg, taicpu(hp1).oper[1]^.ref^)
+                          RegInRef(taicpu(p).oper[0]^.reg, taicpu(next_hp).oper[1]^.ref^) or
+                          RegInRef(taicpu(p).oper[1]^.reg, taicpu(next_hp).oper[1]^.ref^)
                         ) then
                         begin
                           { Remember to update register allocations }
                           if LDRChange then
-                            AllocRegBetween(taicpu(p).oper[1]^.reg, p, hp1, UsedRegs);
+                            AllocRegBetween(taicpu(p).oper[1]^.reg, p, next_hp, UsedRegs);
 
                           Break;
                         end;
 
                       { The register being stored can be potentially changed (as long as it's not the stack pointer) }
-                      if (taicpu(hp1).opcode = A_STR) and (getsupreg(taicpu(p).oper[1]^.reg) <> RS_STACK_POINTER_REG) and
-                        MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[0]^.reg) then
+                      if (taicpu(next_hp).opcode = A_STR) and (getsupreg(taicpu(p).oper[1]^.reg) <> RS_STACK_POINTER_REG) and
+                        MatchOperand(taicpu(next_hp).oper[0]^, taicpu(p).oper[0]^.reg) then
                         begin
-                          DebugMsg('Peephole Optimization: ' + std_regname(taicpu(p).oper[0]^.reg) + ' = ' + std_regname(taicpu(p).oper[1]^.reg) + ' (MovLdr2Ldr 2)', hp1);
-                          taicpu(hp1).oper[0]^.reg := taicpu(p).oper[1]^.reg;
+                          DebugMsg('Peephole Optimization: ' + std_regname(taicpu(p).oper[0]^.reg) + ' = ' + std_regname(taicpu(p).oper[1]^.reg) + ' (MovLdr2Ldr 2)', next_hp);
+                          taicpu(next_hp).oper[0]^.reg := taicpu(p).oper[1]^.reg;
                           LDRChange := True;
                         end;
 
                       if LDRChange and (getsupreg(taicpu(p).oper[1]^.reg) <> RS_STACK_POINTER_REG) then
                         begin
-                          AllocRegBetween(taicpu(p).oper[1]^.reg, p, hp1, UsedRegs);
+                          AllocRegBetween(taicpu(p).oper[1]^.reg, p, next_hp, UsedRegs);
                           if (taicpu(p).oppostfix = PF_None) and
                             (
                               (
-                                (taicpu(hp1).opcode = A_LDR) and
-                                MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[0]^.reg)
+                                (taicpu(next_hp).opcode = A_LDR) and
+                                MatchOperand(taicpu(next_hp).oper[0]^, taicpu(p).oper[0]^.reg)
                               ) or
-                              not RegUsedAfterInstruction(taicpu(p).oper[0]^.reg, hp1, TmpUsedRegs)
+                              not RegUsedAfterInstruction(taicpu(p).oper[0]^.reg, next_hp, TmpUsedRegs)
                             ) and
                             { Double-check to see if the old registers were actually
                               changed (e.g. if the super registers matched, but not
                               the sizes, they won't be changed). }
                             (
-                              (taicpu(hp1).opcode = A_LDR) or
-                              not RegInOp(taicpu(p).oper[0]^.reg, taicpu(hp1).oper[0]^)
+                              (taicpu(next_hp).opcode = A_LDR) or
+                              not RegInOp(taicpu(p).oper[0]^.reg, taicpu(next_hp).oper[0]^)
                             ) and
-                            not RegInRef(taicpu(p).oper[0]^.reg, taicpu(hp1).oper[1]^.ref^) then
+                            not RegInRef(taicpu(p).oper[0]^.reg, taicpu(next_hp).oper[1]^.ref^) then
                             begin
                               DebugMsg('Peephole Optimization: RedundantMovProcess 2a done', p);
                               RemoveCurrentP(p);
@@ -472,23 +472,28 @@ Implementation
                             end;
                         end;
                     end
-                  else if (taicpu(hp1).opcode = A_MOV) and (taicpu(hp1).oppostfix = PF_None) and
-                    (taicpu(hp1).ops = 2) then
+                  else if (taicpu(next_hp).opcode = A_MOV) and (taicpu(next_hp).oppostfix = PF_None) and
+                    (taicpu(next_hp).ops = 2) then
                     begin
-                      if MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[0]^.reg) then
+                      if MatchOperand(taicpu(next_hp).oper[0]^, taicpu(p).oper[0]^.reg) then
                         begin
                           { Found another mov that writes entirely to the register }
-                          if RegUsedBetween(taicpu(p).oper[0]^.reg, p, hp1) then
+                          if RegUsedBetween(taicpu(p).oper[0]^.reg, p, next_hp) then
                             begin
                               { Register was used beforehand }
-                              if MatchOperand(taicpu(hp1).oper[1]^, taicpu(p).oper[1]^.reg) then
+                              if MatchOperand(taicpu(next_hp).oper[1]^, taicpu(p).oper[1]^.reg) then
                                 begin
                                   { This MOV is exactly the same as the first one.
                                     Since none of the registers have changed value
                                     at this point, we can remove it. }
-                                  DebugMsg('Peephole Optimization: RedundantMovProcess 3a done', hp1);
-                                  asml.Remove(hp1);
-                                  hp1.Free;
+                                  DebugMsg('Peephole Optimization: RedundantMovProcess 3a done', next_hp);
+
+                                  if (next_hp = hp1) then
+                                    { Don't let hp1 become a dangling pointer }
+                                    hp1 := nil;
+
+                                  asml.Remove(next_hp);
+                                  next_hp.Free;
 
                                   { We still have the original p, so we can continue optimising;
                                    if it was -O2 or below, this instruction appeared immediately
@@ -504,7 +509,7 @@ Implementation
                           { We can delete the first MOV (only if the second MOV is unconditional) }
 {$ifdef ARM}
                           if (taicpu(p).oppostfix = PF_None) and
-                            (taicpu(hp1).condition = C_None) then
+                            (taicpu(next_hp).condition = C_None) then
 {$endif ARM}
                             begin
                               DebugMsg('Peephole Optimization: RedundantMovProcess 2b done', p);
@@ -513,9 +518,9 @@ Implementation
                             end;
                           Exit;
                         end
-                      else if MatchOperand(taicpu(hp1).oper[1]^, taicpu(p).oper[0]^.reg) then
+                      else if MatchOperand(taicpu(next_hp).oper[1]^, taicpu(p).oper[0]^.reg) then
                         begin
-                          if MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[1]^.reg)
+                          if MatchOperand(taicpu(next_hp).oper[0]^, taicpu(p).oper[1]^.reg)
                             { Be careful - if the entire register is not used, removing this
                               instruction will leave the unused part uninitialised }
 {$ifdef AARCH64}
@@ -524,9 +529,14 @@ Implementation
                             then
                             begin
                               { Instruction will become mov r1,r1 }
-                              DebugMsg('Peephole Optimization: Mov2None 2 done', hp1);
-                              asml.Remove(hp1);
-                              hp1.Free;
+                              DebugMsg('Peephole Optimization: Mov2None 2 done', next_hp);
+
+                              if (next_hp = hp1) then
+                                { Don't let hp1 become a dangling pointer }
+                                hp1 := nil;
+
+                              asml.Remove(next_hp);
+                              next_hp.Free;
                               Continue;
                             end;
 
@@ -534,12 +544,12 @@ Implementation
                             forces it to be left alone if the full register is not
                             used, lest mov w1,w1 gets optimised out by mistake. [Kit] }
 {$ifdef AARCH64}
-                          if not MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[1]^.reg) then
+                          if not MatchOperand(taicpu(next_hp).oper[0]^, taicpu(p).oper[1]^.reg) then
 {$endif AARCH64}
                             begin
-                              DebugMsg('Peephole Optimization: ' + std_regname(taicpu(p).oper[0]^.reg) + ' = ' + std_regname(taicpu(p).oper[1]^.reg) + ' (MovMov2Mov 2)', hp1);
-                              taicpu(hp1).oper[1]^.reg := taicpu(p).oper[1]^.reg;
-                              AllocRegBetween(taicpu(p).oper[1]^.reg, p, hp1, UsedRegs);
+                              DebugMsg('Peephole Optimization: ' + std_regname(taicpu(p).oper[0]^.reg) + ' = ' + std_regname(taicpu(p).oper[1]^.reg) + ' (MovMov2Mov 2)', next_hp);
+                              taicpu(next_hp).oper[1]^.reg := taicpu(p).oper[1]^.reg;
+                              AllocRegBetween(taicpu(p).oper[1]^.reg, p, next_hp, UsedRegs);
 
                               { If this was the only reference to the old register,
                                 then we can remove the original MOV now }
@@ -551,7 +561,7 @@ Implementation
                                   register). [Kit] }
                                 (getsupreg(taicpu(p).oper[1]^.reg) <> RS_STACK_POINTER_REG) and
                                 RegInUsedRegs(taicpu(p).oper[0]^.reg, UsedRegs) and
-                                not RegUsedAfterInstruction(taicpu(p).oper[0]^.reg, hp1, TmpUsedRegs) then
+                                not RegUsedAfterInstruction(taicpu(p).oper[0]^.reg, next_hp, TmpUsedRegs) then
                                 begin
                                   DebugMsg('Peephole Optimization: RedundantMovProcess 2c done', p);
                                   RemoveCurrentP(p);
@@ -565,14 +575,14 @@ Implementation
                   { On low optimisation settions, don't search more than one instruction ahead }
                   if not(cs_opt_level3 in current_settings.optimizerswitches) or
                     { Stop at procedure calls and jumps }
-                    is_calljmp(taicpu(hp1).opcode) or
+                    is_calljmp(taicpu(next_hp).opcode) or
                     { If the read register has changed value, or the MOV
                       destination register has been used, drop out }
-                    RegInInstruction(taicpu(p).oper[0]^.reg, hp1) or
-                    RegModifiedByInstruction(taicpu(p).oper[1]^.reg, hp1) then
+                    RegInInstruction(taicpu(p).oper[0]^.reg, next_hp) or
+                    RegModifiedByInstruction(taicpu(p).oper[1]^.reg, next_hp) then
                     Break;
 
-                  current_hp := hp1;
+                  current_hp := next_hp;
                 end;
             end;
         end;

compiler/comphook.pas

@@ -169,14 +169,7 @@ const
 implementation
 
   uses
-   cutils, systems, globals
-{$ifdef linux}
-   ,termio
-{$endif linux}
-{$ifdef mswindows}
-   ,windows
-{$endif mswindows}
-   ;
+   cutils, systems, globals, comptty;
 
 {****************************************************************************
                           Helper Routines
@@ -214,51 +207,9 @@ end;
 type
   TOutputColor = (oc_black,oc_red,oc_green,oc_orange,og_blue,oc_magenta,oc_cyan,oc_lightgray);
 
-{$if defined(linux) or defined(MSWINDOWS)}
-const
-  CachedIsATTY : Boolean = false;
-  IsATTYValue : Boolean = false;
-
-{$ifdef linux}
-function IsATTY(var t : text) : Boolean;
-  begin
-    if not(CachedIsATTY) then
-      begin
-        IsATTYValue:=termio.IsATTY(t)=1;
-        CachedIsATTY:=true;
-      end;
-    Result:=IsATTYValue;
-  end;
-{$endif linux}
-
-{$ifdef MSWINDOWS}
-const ENABLE_VIRTUAL_TERMINAL_PROCESSING = $0004;
-
-function IsATTY(var t : text) : Boolean;
-  const dwMode: dword = 0;
-  begin
-    if not(CachedIsATTY) then
-      begin
-        IsATTYValue := false;
-        if GetConsoleMode(TextRec(t).handle, dwMode) then
-        begin
-          dwMode := dwMode or ENABLE_VIRTUAL_TERMINAL_PROCESSING;
-          if SetConsoleMode(TextRec(t).handle, dwMode) then
-            IsATTYValue := true;
-        end;
-        CachedIsATTY:=true;
-      end;
-    Result:=IsATTYValue;
-  end;
-{$endif MSWINDOWS}
-
-{$endif defined(linux) or defined(MSWINDOWS)}
-
-
 procedure WriteColoredOutput(var t: Text;color: TOutputColor;const s : AnsiString);
   begin
-{$if defined(linux) or defined(mswindows)}
-     if IsATTY(t) then
+     if TTYCheckSupported and IsATTY(t) then
        begin
          case color of
            oc_black:
@@ -279,12 +230,9 @@ procedure WriteColoredOutput(var t: Text;color: TOutputColor;const s : AnsiStrin
              write(t,#27'[1m'#27'[37m');
          end;
        end;
-{$endif linux or mswindows}
     write(t,s);
-{$if defined(linux) or defined(mswindows)}
-    if IsATTY(t) then
+    if TTYCheckSupported and IsATTY(t) then
       write(t,#27'[0m');
-{$endif linux}
   end;
 {****************************************************************************
                           Stopping the compiler

compiler/comptty.pas

@@ -0,0 +1,172 @@
+{
+    This file is part of the Free Pascal compiler.
+    Copyright (c) 2020 by the Free Pascal development team
+
+    This unit contains platform-specific code for checking TTY output
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit comptty;
+
+{$i fpcdefs.inc}
+
+interface
+
+function IsATTY(var t : text) : Boolean;
+
+const
+(* This allows compile-time removal of the colouring functionality under not supported platforms *)
+{$if defined(linux) or defined(MSWINDOWS) or defined(OS2) or defined(GO32V2) or defined(WATCOM)}
+  TTYCheckSupported = true;
+{$else defined(linux) or defined(MSWINDOWS) or defined(OS2) or defined(GO32V2) or defined(WATCOM)}
+  TTYCheckSupported = false;
+{$endif defined(linux) or defined(MSWINDOWS) or defined(OS2) or defined(GO32V2) or defined(WATCOM)}
+
+
+implementation
+
+{$ifdef linux}
+  uses
+   termio;
+{$endif linux}
+{$ifdef mswindows}
+  uses
+   windows;
+{$endif mswindows}
+{$ifdef os2}
+  uses
+   doscalls;
+{$endif os2}
+{$if defined(GO32V2) or defined(WATCOM)}
+  uses
+   dos;
+{$endif defined(GO32V2) or defined(WATCOM)}
+
+const
+  CachedIsATTY : Boolean = false;
+  IsATTYValue : Boolean = false;
+
+{$ifdef linux}
+function LinuxIsATTY(var t : text) : Boolean; inline;
+begin
+  LinuxIsATTY:=termio.IsATTY(t)=1;
+end;
+{$endif linux}
+
+{$ifdef MSWINDOWS}
+const
+  ENABLE_VIRTUAL_TERMINAL_PROCESSING = $0004;
+
+function WindowsIsATTY(var t : text) : Boolean; inline;
+const
+  dwMode: dword = 0;
+begin
+  WindowsIsATTY := false;
+  if GetConsoleMode(TextRec(t).handle, dwMode) then
+   begin
+    dwMode := dwMode or ENABLE_VIRTUAL_TERMINAL_PROCESSING;
+    if SetConsoleMode(TextRec(t).handle, dwMode) then
+                                     WindowsIsATTY := true;
+   end;
+end;
+{$endif MSWINDOWS}
+
+{$IFDEF OS2}
+function OS2IsATTY(var t : text) : Boolean; inline;
+var
+  HT, Attr: cardinal;
+ {$IFDEF EMX}
+  OK: boolean;
+ {$ENDIF EMX}
+const
+  dhDevice = 1;
+begin
+ {$IFDEF EMX}
+  if os_mode = osOS2 then
+    begin
+ {$ENDIF EMX}
+      OS2IsATTY := (DosQueryHType (TextRec (T).Handle, HT, Attr) = 0)
+                                                           and (HT = dhDevice);
+ {$IFDEF EMX}
+    end
+  else
+    begin
+      OK := false;
+{$ASMMODE INTEL}
+      asm
+        mov ebx, TextRec (T).Handle
+        mov eax, 4400h
+        call syscall
+        jc @IsDevEnd
+        test edx, 80h           { bit 7 is set if it is a device or a pipe }
+        jz @IsDevEnd
+        mov eax, 1A00h          { Check ANSI.SYS availability }
+        int 2Fh
+        inc al                  { If it was FFh, then OK }
+        jnz @IsDevEnd
+        mov OK, true
+@IsDevEnd:
+      end;
+    OS2IsATTY := OK;
+  end;
+ {$ENDIF EMX}
+end;
+{$ENDIF OS2}
+
+{$if defined(GO32V2) or defined(WATCOM)}
+function DosIsATTY(var t : text) : Boolean; inline;
+var
+  Regs: Registers;
+begin
+  Regs.EBX := TextRec (T).Handle;
+  Regs.EAX := $4400;
+  MsDos (Regs);
+  if (Regs.Flags and FCarry <> 0) or (Regs.EDX and $80 = 0) then
+{ bit 7 is set if it is a device or a pipe }
+    DosIsATTY := false
+  else
+    begin
+      Regs.EAX := $1A00;             { Check ANSI.SYS availability }
+      Intr ($2F, Regs);
+      DosIsATTY := Regs.AL = $FF;    { If it was FFh, then OK }
+    end;
+end;
+{$endif defined(GO32V2) or defined(WATCOM)}
+
+function IsATTY(var t : text) : Boolean;
+begin
+  if not(CachedIsATTY) then
+    begin
+(* If none of the supported values is defined, false is returned by default. *)
+{$ifdef linux}
+      IsATTYValue:=LinuxIsATTY(t);
+{$endif linux}
+{$ifdef MSWINDOWS}
+      IsATTYValue:=WindowsIsATTY(t);
+{$endif MSWINDOWS}
+{$ifdef OS2}
+      IsATTYValue:=OS2IsATTY(t);
+{$endif OS2}
+{$if defined(GO32V2) or defined(WATCOM)}
+      IsATTYValue:=DosIsATTY(t);
+{$endif defined(GO32V2) or defined(WATCOM)}
+      CachedIsATTY:=true;
+    end;
+  Result:=IsATTYValue;
+end;
+
+end.

compiler/globals.pas

@@ -413,6 +413,10 @@ interface
        palmos_applicationname : string = 'FPC Application';
        palmos_applicationid : string[4] = 'FPCA';
 {$endif defined(m68k) or defined(arm)}
+{$if defined(m68k)}
+       { Sinclair QL specific }
+       sinclairql_metadata_format: string[4] = 'QHDR';
+{$endif defined(m68k)}
 
        { default name of the C-style "main" procedure of the library/program }
        { (this will be prefixed with the target_info.cprefix)                }
@@ -1516,7 +1520,7 @@ implementation
        if localexepath='' then
         begin
           hs1 := ExtractFileName(exeName);
-	  hs1 := ChangeFileExt(hs1,source_info.exeext);
+          hs1 := ChangeFileExt(hs1,source_info.exeext);
 {$ifdef macos}
           FindFile(hs1,GetEnvironmentVariable('Commands'),false,localExepath);
 {$else macos}

compiler/llvm/agllvm.pas

@@ -407,7 +407,7 @@ implementation
      end;
 
 
-{$if defined(cpuextended) and defined(FPC_HAS_TYPE_EXTENDED)}
+{$if defined(cpuextended) and (defined(FPC_HAS_TYPE_EXTENDED) or defined(FPC_SOFT_FPUX80))}
     function llvmextendedtostr(const e: extended): TSymStr;
       var
         extendedval: record
@@ -502,7 +502,7 @@ implementation
                end;
              result:='';
            end;
-{$if defined(cpuextended) and defined(FPC_HAS_TYPE_EXTENDED)}
+{$if defined(cpuextended) and (defined(FPC_HAS_TYPE_EXTENDED) or defined(FPC_SOFT_FPUX80))}
          top_extended80:
            begin
              result:=llvmextendedtostr(o.eval);
@@ -875,7 +875,7 @@ implementation
                 writer.AsmWriteLn(asminfo^.comment+'value: '+single2str(tai_realconst(hp).value.s32val));
               aitrealconst_s64bit:
                 writer.AsmWriteLn(asminfo^.comment+'value: '+double2str(tai_realconst(hp).value.s64val));
-{$if defined(cpuextended) and defined(FPC_HAS_TYPE_EXTENDED)}
+{$if defined(cpuextended) and (defined(FPC_HAS_TYPE_EXTENDED) or defined(FPC_SOFT_FPUX80))}
               { can't write full 80 bit floating point constants yet on non-x86 }
               aitrealconst_s80bit:
                 writer.AsmWriteLn(asminfo^.comment+'value: '+extended2str(tai_realconst(hp).value.s80val));
@@ -892,7 +892,7 @@ implementation
             writer.AsmWrite(llvmdoubletostr(hp.value.s32val));
           aitrealconst_s64bit:
             writer.AsmWriteln(llvmdoubletostr(hp.value.s64val));
-{$if defined(cpuextended) and defined(FPC_HAS_TYPE_EXTENDED)}
+{$if defined(cpuextended) and (defined(FPC_HAS_TYPE_EXTENDED) or defined(FPC_SOFT_FPUX80))}
           aitrealconst_s80bit:
             writer.AsmWrite(llvmextendedtostr(hp.value.s80val));
 {$endif defined(cpuextended)}

compiler/llvm/llvmdef.pas

@@ -898,56 +898,72 @@ implementation
 
 
     function llvmgettemprecorddef(const fieldtypes: array of tdef; packrecords, recordalignmin: shortint): trecorddef;
+
+      procedure addtypename(var typename: TSymStr; hdef: tdef);
+        begin
+          case hdef.typ of
+            orddef:
+              case torddef(hdef).ordtype of
+                s8bit,
+                u8bit,
+                pasbool1,
+                pasbool8:
+                  typename:=typename+'i8';
+                s16bit,
+                u16bit:
+                  typename:=typename+'i16';
+                s32bit,
+                u32bit:
+                  typename:=typename+'i32';
+                s64bit,
+                u64bit:
+                  typename:=typename+'i64';
+                customint:
+                  typename:=typename+'i'+tostr(torddef(hdef).packedbitsize);
+                else
+                  { other types should not appear currently, add as needed }
+                  internalerror(2014012001);
+              end;
+            floatdef:
+              case tfloatdef(hdef).floattype of
+                s32real:
+                  typename:=typename+'f32';
+                s64real:
+                  typename:=typename+'f64';
+                else
+                  { other types should not appear currently, add as needed }
+                  internalerror(2014012008);
+              end;
+            arraydef:
+              begin
+                if not is_special_array(hdef) and
+                   not is_packed_array(hdef) then
+                  begin
+                    typename:=typename+'['+tostr(tarraydef(hdef).elecount)+'x';
+                    addtypename(typename,tarraydef(hdef).elementdef);
+                    typename:=typename+']';
+                  end
+                else
+                  typename:=typename+'d'+hdef.unique_id_str;
+              end
+            else
+              typename:=typename+'d'+hdef.unique_id_str;
+          end;
+        end;
+
       var
         i: longint;
         res: PHashSetItem;
         oldsymtablestack: tsymtablestack;
         hrecst: trecordsymtable;
-        hdef: tdef;
         hrecdef: trecorddef;
         sym: tfieldvarsym;
-        typename: string;
+        typename: TSymStr;
       begin
         typename:=internaltypeprefixName[itp_llvmstruct];
         for i:=low(fieldtypes) to high(fieldtypes) do
           begin
-            hdef:=fieldtypes[i];
-            case hdef.typ of
-              orddef:
-                case torddef(hdef).ordtype of
-                  s8bit,
-                  u8bit,
-                  pasbool1,
-                  pasbool8:
-                    typename:=typename+'i8';
-                  s16bit,
-                  u16bit:
-                    typename:=typename+'i16';
-                  s32bit,
-                  u32bit:
-                    typename:=typename+'i32';
-                  s64bit,
-                  u64bit:
-                    typename:=typename+'i64';
-                  customint:
-                    typename:=typename+'i'+tostr(torddef(hdef).packedbitsize);
-                  else
-                    { other types should not appear currently, add as needed }
-                    internalerror(2014012001);
-                end;
-              floatdef:
-                case tfloatdef(hdef).floattype of
-                  s32real:
-                    typename:=typename+'f32';
-                  s64real:
-                    typename:=typename+'f64';
-                  else
-                    { other types should not appear currently, add as needed }
-                    internalerror(2014012008);
-                end;
-              else
-                typename:=typename+'d'+hdef.unique_id_str;
-            end;
+            addtypename(typename,fieldtypes[i]);
           end;
         if not assigned(current_module) then
           internalerror(2014012002);

compiler/m68k/ra68kmot.pas

@@ -83,7 +83,7 @@ unit ra68kmot;
          procedure consume_all_until(tokens : tasmtokenset);
          function findopcode(const s: string; var opsize: topsize): tasmop;
          Function BuildExpression(allow_symbol : boolean; asmsym : pshortstring) : tcgint;
-         Procedure BuildConstant(maxvalue: tcgint);
+         Procedure BuildConstant(constsize: tcgint);
          Procedure BuildRealConstant(typ : tfloattype);
          Procedure BuildScaling(const oper:tm68koperand);
          Function BuildRefExpression: tcgint;
@@ -932,72 +932,53 @@ const
   end;
 
 
-  Procedure tm68kmotreader.BuildConstant(maxvalue: tcgint);
+  procedure tm68kmotreader.BuildConstant(constsize: tcgint);
   {*********************************************************************}
   { PROCEDURE BuildConstant                                             }
   {  Description: This routine takes care of parsing a DB,DD,or DW      }
   {  line and adding those to the assembler node. Expressions, range-   }
-  {  checking are fullly taken care of.                                 }
-  {   maxvalue: $ff -> indicates that this is a DB node.                }
-  {             $ffff -> indicates that this is a DW node.              }
-  {             $ffffffff -> indicates that this is a DD node.          }
+  {  checking are fully taken care of.                                  }
   {*********************************************************************}
   { EXIT CONDITION:  On exit the routine should point to AS_SEPARATOR.  }
   {*********************************************************************}
   var
-   expr: string;
-   value : tcgint;
+    expr: string;
+    value : tcgint;
   begin
-      Repeat
-        Case actasmtoken of
-          AS_STRING: begin
-                      if maxvalue <> $ff then
-                         Message(asmr_e_string_not_allowed_as_const);
-                      expr := actasmpattern;
-                      if length(expr) > 1 then
-                        Message(asmr_e_string_not_allowed_as_const);
-                      Consume(AS_STRING);
-                      Case actasmtoken of
-                       AS_COMMA: Consume(AS_COMMA);
-                       AS_SEPARATOR: ;
-                      else
-                       Message(asmr_e_invalid_string_expression);
-                      end; { end case }
-                      ConcatString(curlist,expr);
-                    end;
-          AS_INTNUM,AS_BINNUM,
-          AS_OCTALNUM,AS_HEXNUM:
-                    begin
-                      value:=BuildExpression(false,nil);
-                      ConcatConstant(curlist,value,maxvalue);
-                    end;
-          AS_ID:
-                     begin
-                      value:=BuildExpression(false,nil);
-                      if value > maxvalue then
-                      begin
-                         Message(asmr_e_constant_out_of_bounds);
-                         { assuming a value of maxvalue }
-                         value := maxvalue;
-                      end;
-                      ConcatConstant(curlist,value,maxvalue);
-                  end;
-          { These terms can start an assembler expression }
-          AS_PLUS,AS_MINUS,AS_LPAREN,AS_NOT: begin
-                                          value := BuildExpression(false,nil);
-                                          ConcatConstant(curlist,value,maxvalue);
-                                         end;
-          AS_COMMA:  begin
-                       Consume(AS_COMMA);
-                     END;
-          AS_SEPARATOR: ;
+    repeat
+      case actasmtoken of
+        AS_STRING:
+            begin
+              expr:=actasmpattern;
+              Consume(AS_STRING);
+              if (constsize <> 1) or (length(expr) > 1) then
+                Message(asmr_e_string_not_allowed_as_const);
 
-        else
-         begin
-           Message(asmr_e_syntax_error);
-         end;
-    end; { end case }
-   Until actasmtoken = AS_SEPARATOR;
+              if not (actasmtoken in [AS_COMMA, AS_SEPARATOR]) then
+                Message(asmr_e_invalid_string_expression);
+
+              ConcatString(curlist,expr);
+            end;
+        AS_ID,
+        AS_INTNUM,AS_BINNUM,
+        AS_OCTALNUM,AS_HEXNUM,
+        { These terms can start an assembler expression }
+        AS_PLUS,AS_MINUS,AS_LPAREN,AS_NOT:
+            begin
+              value:=BuildExpression(false,nil);
+              ConcatConstant(curlist,value,constsize);
+            end;
+        AS_COMMA:
+            begin
+              Consume(AS_COMMA);
+            end;
+        AS_SEPARATOR: ;
+      else
+        begin
+          Message(asmr_e_syntax_error);
+        end;
+      end; { end case }
+    until actasmtoken = AS_SEPARATOR;
   end;
 
 
@@ -1713,17 +1694,17 @@ const
               AS_DW:
                 begin
                   Consume(AS_DW);
-                  BuildConstant($ffff);
+                  BuildConstant(sizeof(word));
                 end;
               AS_DB:
                 begin
                   Consume(AS_DB);
-                  BuildConstant($ff);
+                  BuildConstant(sizeof(byte));
                 end;
               AS_DD:
                 begin
                   Consume(AS_DD);
-                  BuildConstant(tcgint($ffffffff));
+                  BuildConstant(sizeof(dword));
                 end;
               AS_XDEF:
                 begin

compiler/msg/errore.msg

@@ -4319,6 +4319,9 @@ A*2WR_Generate relocation code (Windows)
 8*3Wtexe_Create a DOS .EXE file (default)
 8*3Wtcom_Create a DOS .COM file (requires tiny memory model)
 P*2WT_Specify MPW tool type application (Classic Mac OS)
+6*2WQ<x>_Set executable metadata format (Sinclair QL)
+6*3WQqhdr_Set metadata to QDOS File Header style (default)
+6*3WQxtcc_Set metadata to XTcc style
 **2WX_Enable executable stack (Linux)
 **1X_Executable options:
 **2X9_Generate linkerscript for GNU Binutils ld older than version 2.19.1 (Linux)

compiler/msgidx.inc

@@ -1135,7 +1135,7 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 86604;
+  MsgTxtSize = 86754;
 
   MsgIdxMax : array[1..20] of longint=(
     28,107,360,130,99,63,145,36,223,68,

compiler/msgtxt.inc

@@ -1,8 +1,8 @@
 const msgtxt_codepage=20127;
 {$ifdef Delphi}
-const msgtxt : array[0..000360] of string[240]=(
+const msgtxt : array[0..000361] of string[240]=(
 {$else Delphi}
-const msgtxt : array[0..000360,1..240] of char=(
+const msgtxt : array[0..000361,1..240] of char=(
 {$endif Delphi}
   '01000_T_Compiler: $1'#000+
   '01001_D_Compiler OS: $1'#000+
@@ -1960,42 +1960,46 @@ const msgtxt : array[0..000360,1..240] of char=(
   '8*3Wtexe_Create a DOS .EXE file (default)'#010+
   '8*3Wtcom_Create a DOS .COM file (requires tiny memory model)'#010+
   'P*2WT_Specify MPW tool type application (Classic Mac OS)'#010+
+  '6*2WQ<x>_Set executable metadata format (Sinclair QL)'#010+
+  '6*3WQqhdr_Set metad','ata to QDOS File Header style (default)'#010+
+  '6*3WQxtcc_Set metadata to XTcc style'#010+
   '**2WX_Enable executable stack (Linux)'#010+
   '**1X_Executable options:'#010+
-  '**2X9_Gene','rate linkerscript for GNU Binutils ld older than version 2'+
-  '.19.1 (Linux)'#010+
-  '**2Xc_Pass --shared/-dynamic to the linker (BeOS, Darwin, FreeBSD, Lin'+
-  'ux)'#010+
+  '**2X9_Generate linkerscript for GNU Binutils ld older than version 2.1'+
+  '9.1 (Linux)'#010+
+  '**2Xc_Pass --share','d/-dynamic to the linker (BeOS, Darwin, FreeBSD, L'+
+  'inux)'#010+
   '**2Xd_Do not search default library path (sometimes required for cross'+
-  '-compiling when not usin','g -XR)'#010+
+  '-compiling when not using -XR)'#010+
   '**2Xe_Use external linker'#010+
   '**2Xf_Substitute pthread library name for linking (BSD)'#010+
-  '**2Xg_Create debuginfo in a separate file and add a debuglink section '+
-  'to executable'#010+
-  '**2XD_Try to link units dynamically      (defines FPC_LINK_DYNAMIC)',#010+
+  '*','*2Xg_Create debuginfo in a separate file and add a debuglink sectio'+
+  'n to executable'#010+
+  '**2XD_Try to link units dynamically      (defines FPC_LINK_DYNAMIC)'#010+
   '**2Xi_Use internal linker'#010+
-  'L*2XlS<x>_LLVM utilties suffix (e.g. -7 in case clang is called clang-'+
-  '7)'#010+
+  'L*2XlS<x>_LLVM utilties suffix (e.g. -7 in case clang is called',' clan'+
+  'g-7)'#010+
   '**2XLA_Define library substitutions for linking'#010+
   '**2XLO_Define order of library linking'#010+
   '**2XLD_Exclude default order of standard libraries'#010+
-  '**','2Xm_Generate link map'#010+
+  '**2Xm_Generate link map'#010+
   '**2XM<x>_Set the name of the '#039'main'#039' program routine (default i'+
-  's '#039'main'#039')'#010+
+  's '#039'mai','n'#039')'#010+
   '**2Xn_Use target system native linker instead of GNU ld (Solaris, AIX)'+
   #010+
   'F*2Xp<x>_First search for the compiler binary in the directory <x>'#010+
-  '**2XP<x>','_Prepend the binutils names with the prefix <x>'#010+
-  '**2Xr<x>_Set the linker'#039's rlink-path to <x> (needed for cross comp'+
-  'ile, see the ld manual for more information) (BeOS, Linux)'#010+
-  '**2XR<x>_Prepend <x> to all linker search paths (BeOS, Darwin, Free','B'+
-  'SD, Linux, Mac OS, Solaris)'#010+
+  '**2XP<x>_Prepend the binutils names with the prefix <x>'#010+
+  '**2Xr<x>_Set the linker'#039's rlink-path to <x','> (needed for cross co'+
+  'mpile, see the ld manual for more information) (BeOS, Linux)'#010+
+  '**2XR<x>_Prepend <x> to all linker search paths (BeOS, Darwin, FreeBSD'+
+  ', Linux, Mac OS, Solaris)'#010+
   '**2Xs_Strip all symbols from executable'#010+
-  '**2XS_Try to link units statically (default, defines FPC_LINK_STATIC)'#010+
+  '**2XS_Try to link uni','ts statically (default, defines FPC_LINK_STATIC'+
+  ')'#010+
   '**2Xt_Link with static libraries (-static is passed to linker)'#010+
-  '**2Xv_Generate table for Virtual Entry',' calls'#010+
+  '**2Xv_Generate table for Virtual Entry calls'#010+
   '**2XV_Use VLink as external linker       (default on Amiga, MorphOS)'#010+
-  '**2XX_Try to smartlink units             (defines FPC_LINK_SMART)'#010+
+  '**2XX_Try to s','martlink units             (defines FPC_LINK_SMART)'#010+
   '**1*_'#010+
   '**1?_Show this help'#010+
   '**1h_Shows this help without waiting'

compiler/options.pas

@@ -2601,6 +2601,23 @@ begin
                         else
                           IllegalPara(opt);
                       end;
+{$if defined(m68k)}
+                    'Q':
+                      begin
+                        if (target_info.system in [system_m68k_sinclairql]) then
+                          begin
+                            sinclairql_metadata_format:=Upper(Copy(More,j+1,255));
+                            case sinclairql_metadata_format of
+                              'QHDR', 'XTCC': ; { allowed formats }
+                              else
+                                IllegalPara(opt);
+                            end;
+                            break;
+                          end
+                        else
+                          IllegalPara(opt);
+                      end;
+{$endif defined(m68k)}
                     'R':
                       begin
                         if target_info.system in systems_all_windows then
@@ -4394,44 +4411,61 @@ begin
       ;
   end;
 
-  { ARMHF defaults }
-  if (target_info.abi = abi_eabihf) then
-    { set default cpu type to ARMv7a for ARMHF unless specified otherwise }
-    begin
-    {$ifdef CPUARMV6}
-      { if the compiler is built for armv6, then
-        inherit this setting, e.g. Raspian is armhf but
-        only armv6, this makes rebuilds of the compiler
-        easier }
-      if not option.CPUSetExplicitly then
-        init_settings.cputype:=cpu_armv6;
-      if not option.OptCPUSetExplicitly then
-        init_settings.optimizecputype:=cpu_armv6;
-    {$else CPUARMV6}
-      if not option.CPUSetExplicitly then
-        init_settings.cputype:=cpu_armv7a;
-      if not option.OptCPUSetExplicitly then
-        init_settings.optimizecputype:=cpu_armv7a;
-    {$endif CPUARMV6}
+  { set ABI defaults }
+  case target_info.abi of
+    abi_eabihf:
+      { set default cpu type to ARMv7a for ARMHF unless specified otherwise }
+      begin
+{$ifdef CPUARMV6}
+        { if the compiler is built for armv6, then
+          inherit this setting, e.g. Raspian is armhf but
+          only armv6, this makes rebuilds of the compiler
+          easier }
+        if not option.CPUSetExplicitly then
+          init_settings.cputype:=cpu_armv6;
+        if not option.OptCPUSetExplicitly then
+          init_settings.optimizecputype:=cpu_armv6;
+{$else CPUARMV6}
+        if not option.CPUSetExplicitly then
+          init_settings.cputype:=cpu_armv7a;
+        if not option.OptCPUSetExplicitly then
+          init_settings.optimizecputype:=cpu_armv7a;
+{$endif CPUARMV6}
 
-      { Set FPU type }
-      if not(option.FPUSetExplicitly) then
-        begin
-          if init_settings.cputype < cpu_armv7 then
-            init_settings.fputype:=fpu_vfpv2
-          else
-            init_settings.fputype:=fpu_vfpv3_d16;
-        end
-      else
-        begin
-          if (not(FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[init_settings.fputype]))
-	     or (target_info.system = system_arm_ios) then
-            begin
-              Message(option_illegal_fpu_eabihf);
-              StopOptions(1);
-            end;
-        end;
-    end;
+        { Set FPU type }
+        if not(option.FPUSetExplicitly) then
+          begin
+            if init_settings.cputype < cpu_armv7 then
+              init_settings.fputype:=fpu_vfpv2
+            else
+              init_settings.fputype:=fpu_vfpv3_d16;
+          end
+        else
+          begin
+            if (not(FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[init_settings.fputype]))
+	       or (target_info.system = system_arm_ios) then
+              begin
+                Message(option_illegal_fpu_eabihf);
+                StopOptions(1);
+              end;
+          end;
+      end;
+    abi_eabi:
+      begin
+        if target_info.system=system_arm_linux then
+          begin
+            { this is what Debian uses }
+            if not option.CPUSetExplicitly then
+              init_settings.cputype:=cpu_armv4t;
+            if not option.OptCPUSetExplicitly then
+              init_settings.optimizecputype:=cpu_armv4t;
+            if not(option.FPUSetExplicitly) then
+              init_settings.fputype:=fpu_soft;
+          end;
+      end;
+    else
+      ;
+  end;
 
   if (init_settings.instructionset=is_thumb) and not(CPUARM_HAS_THUMB2 in cpu_capabilities[init_settings.cputype]) then
     begin

compiler/rautils.pas

@@ -1795,13 +1795,8 @@ end;
 
 Procedure ConcatConstant(p: TAsmList; value: tcgint; constsize:byte);
 {*********************************************************************}
-{ PROCEDURE ConcatConstant(value: aint; maxvalue: aint);        }
 {  Description: This routine adds the value constant to the current   }
 {  instruction linked list.                                           }
-{   maxvalue -> indicates the size of the data to initialize:         }
-{                  $ff -> create a byte node.                         }
-{                  $ffff -> create a word node.                       }
-{                  $ffffffff -> create a dword node.                  }
 {*********************************************************************}
 var
   rangelo,rangehi : int64;

compiler/riscv/agrvgas.pas

@@ -247,7 +247,10 @@ unit agrvgas;
         Replace(result,'$ABI','ilp32');
 {$endif RISCV32}
 {$ifdef RISCV64}
-        Replace(result,'$ABI','lp64');
+        if target_info.abi=abi_riscv_hf then
+          Replace(result,'$ABI','lp64d')
+        else
+          Replace(result,'$ABI','lp64');
 {$endif RISCV64}
       end;
 

compiler/systems/i_sinclairql.pas

@@ -39,7 +39,7 @@ unit i_sinclairql;
             cpu          : cpu_m68k;
             unit_env     : '';
             extradefines : '';
-            exeext       : '.bin';
+            exeext       : '.exe';
             defext       : '';
             scriptext    : '';
             smartext     : '.sl';

compiler/systems/t_amiga.pas

@@ -385,11 +385,15 @@ var
   StripStr: string[40];
   DynLinkStr : string;
   GCSectionsStr : string;
+  MapStr: string;
 begin
   StripStr:='';
   GCSectionsStr:='';
   DynLinkStr:='';
+  MapStr:='';
 
+  if UseVlink and (cs_link_map in current_settings.globalswitches) then
+    MapStr:='-M'+Unix2AmigaPath(maybequoted(ScriptFixFilename(current_module.mapfilename)));
   if (cs_link_strip in current_settings.globalswitches) then
     StripStr:='-s';
   if rlinkpath<>'' Then
@@ -406,6 +410,7 @@ begin
   Replace(cmdstr,'$OPT',Info.ExtraOptions);
   Replace(cmdstr,'$EXE',Unix2AmigaPath(maybequoted(ScriptFixFileName(current_module.exefilename))));
   Replace(cmdstr,'$RES',Unix2AmigaPath(maybequoted(ScriptFixFileName(outputexedir+Info.ResName))));
+  Replace(cmdstr,'$MAP',MapStr);
   Replace(cmdstr,'$STRIP',StripStr);
   Replace(cmdstr,'$GCSECTIONS',GCSectionsStr);
   Replace(cmdstr,'$DYNLINK',DynLinkStr);

compiler/systems/t_atari.pas

@@ -73,7 +73,7 @@ begin
      end
     else
      begin
-      ExeCmd[1]:='vlink -b ataritos $FLAGS $GCSECTIONS $OPT $STRIP -o $EXE -T $RES';
+      ExeCmd[1]:='vlink -b ataritos $FLAGS $GCSECTIONS $OPT $STRIP $MAP -o $EXE -T $RES';
      end;
    end;
 end;
@@ -215,13 +215,17 @@ var
   DynLinkStr : string;
   GCSectionsStr : string;
   FlagsStr : string;
+  MapStr: string;
   ExeName: string;
 begin
   StripStr:='';
   GCSectionsStr:='';
   DynLinkStr:='';
+  MapStr:='';
   FlagsStr:='-tos-flags fastload,fastram';
 
+  if UseVlink and (cs_link_map in current_settings.globalswitches) then
+    MapStr:='-M'+maybequoted(ScriptFixFileName(current_module.mapfilename));
   if (cs_link_strip in current_settings.globalswitches) then
     StripStr:='-s';
   if rlinkpath<>'' then
@@ -242,6 +246,7 @@ begin
   Replace(cmdstr,'$OPT',Info.ExtraOptions);
   Replace(cmdstr,'$EXE',maybequoted(ScriptFixFileName(ExeName)));
   Replace(cmdstr,'$RES',maybequoted(ScriptFixFileName(outputexedir+Info.ResName)));
+  Replace(cmdstr,'$MAP',MapStr);
   Replace(cmdstr,'$FLAGS',FlagsStr);
   Replace(cmdstr,'$STRIP',StripStr);
   Replace(cmdstr,'$GCSECTIONS',GCSectionsStr);

compiler/systems/t_sinclairql.pas

@@ -35,7 +35,6 @@ type
     private
       Origin: DWord;
       UseVLink: boolean;
-      ExeLength: longint;
       function WriteResponseFile(isdll: boolean): boolean;
       procedure SetSinclairQLInfo;
       function MakeSinclairQLExe: boolean;
@@ -53,6 +52,37 @@ implementation
        sysutils,cutils,cfileutl,cclasses,aasmbase,
        globtype,globals,systems,verbose,cscript,fmodule,i_sinclairql;
 
+    type
+      TQLHeader = packed record
+        hdr_id: array[0..17] of char;
+        hdr_reserved: byte;
+        hdr_length: byte;
+        hdr_access: byte;
+        hdr_type: byte;
+        hdr_data: dword;
+        hdr_extra: dword;
+      end;
+
+      TXTccData = packed record
+        xtcc_id: array[0..3] of char;
+        xtcc_data: dword;
+      end;
+
+    const
+      DefaultQLHeader: TQLHeader = (
+        hdr_id: ']!QDOS File Header';
+        hdr_reserved: 0;
+        hdr_length: $f;
+        hdr_access: 0;
+        hdr_type: 1;
+        hdr_data: 0;
+        hdr_extra: 0;
+      );
+
+      DefaultXTccData: TXTCCData = (
+        xtcc_id: 'XTcc';
+        xtcc_data: 0;
+      );
 
     const
        DefaultOrigin = $0;
@@ -85,7 +115,7 @@ begin
      end
     else
      begin
-      ExeCmd[1]:='vlink -b rawseg -q $FLAGS $GCSECTIONS $OPT $STRIP -o $EXE -T $RES';
+      ExeCmd[1]:='vlink -b rawseg -q $FLAGS $GCSECTIONS $OPT $STRIP $MAP -o $EXE -T $RES';
      end;
    end;
 end;
@@ -213,6 +243,7 @@ var
   DynLinkStr : string;
   GCSectionsStr : string;
   FlagsStr : string;
+  MapStr : string;
   ExeName: string;
   fd,fs: file;
   fhdr: text;
@@ -222,12 +253,19 @@ var
   HeaderLine: string;
   HeaderSize: longint;
   code: word;
+  QLHeader: TQLHeader;
+  XTccData: TXTccData;
+  BinSize: longint;
+  DataSpace: DWord;
 begin
   StripStr:='';
   GCSectionsStr:='';
   DynLinkStr:='';
   FlagsStr:='';
+  MapStr:='';
 
+  if (cs_link_map in current_settings.globalswitches) then
+    MapStr:='-M'+maybequoted(ScriptFixFilename(current_module.mapfilename));
   if (cs_link_strip in current_settings.globalswitches) then
     StripStr:='-s';
   if rlinkpath<>'' then
@@ -247,6 +285,7 @@ begin
   Replace(cmdstr,'$OPT',Info.ExtraOptions);
   Replace(cmdstr,'$EXE',maybequoted(ScriptFixFileName(ExeName)));
   Replace(cmdstr,'$RES',maybequoted(ScriptFixFileName(outputexedir+Info.ResName)));
+  Replace(cmdstr,'$MAP',MapStr);
   Replace(cmdstr,'$FLAGS',FlagsStr);
   Replace(cmdstr,'$STRIP',StripStr);
   Replace(cmdstr,'$GCSECTIONS',GCSectionsStr);
@@ -259,7 +298,10 @@ begin
       and the relocation info. Here we copy the two together. (KB) }
   if MakeSinclairQLExe then
     begin
-      ExeLength:=0;
+      QLHeader:=DefaultQLHeader;
+      XTccData:=DefaultXTccData;
+
+      BinSize:=0;
       bufsize:=16384;
 {$push}
 {$i-}
@@ -279,6 +321,19 @@ begin
 
       assign(fs,ExeName+'.'+ProgramHeaderName);
       reset(fs,1);
+      BinSize := FileSize(fs);
+
+      { We assume .bss size is total size indicated by linker minus emmited binary.
+        DataSpace size is .bss + stack space }
+      DataSpace := NToBE(DWord(HeaderSize - BinSize + StackSize));
+
+      { Option: prepend QEmuLator and QPC2 v5 compatible header to EXE }
+      if sinclairql_metadata_format='QHDR' then
+        begin
+          QLHeader.hdr_data:=DataSpace;
+          blockwrite(fd, QLHeader, sizeof(QLHeader));
+        end;
+
       repeat
         blockread(fs,buf^,bufsize,bufread);
         blockwrite(fd,buf^,bufread);
@@ -295,25 +350,29 @@ begin
       close(fs);
       // erase(fs);
 
-      ExeLength:=FileSize(fd);
+      { Option: append cross compilation data space marker, this can be picked up by
+        a special version of InfoZIP (compiled with -DQLZIP and option -Q) or by any
+        of the XTcc unpack utilities }
+      if sinclairql_metadata_format='XTCC' then
+        begin
+          XTccData.xtcc_data:=DataSpace;
+          blockwrite(fd, XTccData, sizeof(XTccData));
+        end;
+
       close(fd);
 {$pop}
       FreeMem(buf);
-      if HeaderSize > ExeLength then
-        ExeLength:=HeaderSize;
-      MakeSinclairQLExe:=(code = 0) and not (ExeLength = 0);
+
+      MakeSinclairQLExe:=(code = 0) and not (BinSize = 0) and (IOResult = 0);
     end;
 end;
 
 
 function TLinkerSinclairQL.MakeExecutable:boolean;
-const
-  DefaultBootString = '10 $SYM=RESPR($BINSIZE):LBYTES"win1_$EXENAME",$SYM:CALL $SYM';
 var
   success : boolean;
   bootfile : TScript;
   ExeName: String;
-  BootStr: String;
 begin
   if not(cs_link_nolink in current_settings.globalswitches) then
     Message1(exec_i_linking,current_module.exefilename);
@@ -327,24 +386,6 @@ begin
   if (success) and not(cs_link_nolink in current_settings.globalswitches) then
     DeleteFile(outputexedir+Info.ResName);
 
-  if (success) then
-    begin
-      ExeName:=current_module.exefilename;
-      BootStr:=DefaultBootString;
-
-      Replace(BootStr,'$BINSIZE',tostr(ExeLength));
-      Replace(BootStr,'$EXENAME',ExeName);
-
-      Replace(ExeName,target_info.exeext,'');
-      Replace(BootStr,'$SYM',ExeName);
-
-      { Write bootfile }
-      bootfile:=TScript.Create(outputexedir+ExeName);
-      bootfile.Add(BootStr);
-      bootfile.writetodisk;
-      bootfile.Free;
-    end;
-
   MakeExecutable:=success;   { otherwise a recursive call to link method }
 end;
 

compiler/systems/t_zxspectrum.pas

@@ -210,7 +210,7 @@ procedure TLinkerZXSpectrum.SetDefaultInfo_Vlink;
       FOrigin:=DefaultOrigin;
     with Info do
      begin
-       ExeCmd[1]:=ExeName+' -bihex $GCSECTIONS -e $STARTSYMBOL $STRIP $OPT -o $EXE -T $RES'
+       ExeCmd[1]:=ExeName+' -bihex $GCSECTIONS -e $STARTSYMBOL $STRIP $OPT $MAP -o $EXE -T $RES'
      end;
   end;
 
@@ -280,13 +280,18 @@ function TLinkerZXSpectrum.MakeExecutable_Vlink: boolean;
     GCSectionsStr,
     StripStr,
     StartSymbolStr,
+    MapStr,
     FixedExeFilename: string;
   begin
     GCSectionsStr:='-gc-all -mtype';
     StripStr:='';
+    MapStr:='';
     StartSymbolStr:='start';
     FixedExeFileName:=maybequoted(ScriptFixFileName(ChangeFileExt(current_module.exefilename,'.ihx')));
 
+    if (cs_link_map in current_settings.globalswitches) then
+      MapStr:='-M'+maybequoted(ScriptFixFileName(current_module.mapfilename));
+
   { Write used files and libraries }
     WriteResponseFile_Vlink();
 
@@ -296,6 +301,7 @@ function TLinkerZXSpectrum.MakeExecutable_Vlink: boolean;
 
     Replace(cmdstr,'$EXE',FixedExeFileName);
     Replace(cmdstr,'$RES',(maybequoted(ScriptFixFileName(outputexedir+Info.ResName))));
+    Replace(cmdstr,'$MAP',MapStr);
     Replace(cmdstr,'$STRIP',StripStr);
     Replace(cmdstr,'$STARTSYMBOL',StartSymbolStr);
     Replace(cmdstr,'$GCSECTIONS',GCSectionsStr);

compiler/utils/Makefile

@@ -3283,7 +3283,7 @@ ppumove$(EXEEXT): ppumove.pp ppu$(PPUEXT)
 	$(MAKE) ppumove$(EXEEXT) NOCPUDEF=1
 else
 ppu$(PPUEXT): ../ppu.pas
-	$(COMPILER) ../ppu.pas -Fu../generic -dGENERIC_CPU -Fi..
+	$(COMPILER) ../ppu.pas -Fu../llvm -Fu../generic -dGENERIC_CPU -Fi..
 ppudump$(EXEEXT): ppuutils/ppudump.pp ppu$(PPUEXT)
 	$(COMPILER) ppuutils/ppudump.pp -Fu../llvm -Fu../generic -dGENERIC_CPU -Fi..
 ppufiles$(EXEEXT): ppufiles.pp ppu$(PPUEXT)

compiler/utils/Makefile.fpc

@@ -57,7 +57,7 @@ ppumove$(EXEEXT): ppumove.pp ppu$(PPUEXT)
 
 else
 ppu$(PPUEXT): ../ppu.pas
-        $(COMPILER) ../ppu.pas -Fu../generic -dGENERIC_CPU -Fi..
+        $(COMPILER) ../ppu.pas -Fu../llvm -Fu../generic -dGENERIC_CPU -Fi..
 
 ppudump$(EXEEXT): ppuutils/ppudump.pp ppu$(PPUEXT)
         $(COMPILER) ppuutils/ppudump.pp -Fu../llvm -Fu../generic -dGENERIC_CPU -Fi..

compiler/xtensa/agcpugas.pas

@@ -78,30 +78,32 @@ unit agcpugas;
       begin
          with ref do
           begin
-{$ifdef extdebug}
-            // if base=NR_NO then
-            //   internalerror(200308292);
-
-            // if ((index<>NR_NO) or (shiftmode<>SM_None)) and ((offset<>0) or (symbol<>nil)) then
-            //   internalerror(200308293);
-{$endif extdebug}
-
             if assigned(symbol) then
               begin
                 s:=symbol.name;
                 if offset<>0 then
                   s:=s+tostr_with_plus(offset);
-                if refaddr=addr_pic then
-                  s:=s+'(PLT)'
-                {else if refaddr=addr_tlscall then
-                  s:=s+'(tlscall)'};
+                case refaddr of
+                  addr_pic:
+                    s:=s+'(PLT)';
+                  addr_full,
+                  addr_no:
+                    ;
+                  else
+                    Internalerror(2020112403);
+                end;
               end
             else
               begin
                 s:=gas_regname(base);
                 if index<>NR_NO then
-                  Internalerror(2020030802);
-                s:=s+','+tostr(offset);
+                  begin
+                    s:=s+','+gas_regname(index);
+                    if offset<>0 then
+                      Internalerror(2020112402);
+                  end
+                else
+                  s:=s+','+tostr(offset);
               end;
           end;
         getreferencestring:=s;

compiler/xtensa/cgcpu.pas

@@ -1179,11 +1179,14 @@ implementation
            InternalError(2020032602);
          href:=ref;
          if assigned(href.symbol) or
-           (href.index<>NR_NO) or
+           ((href.index<>NR_NO) and (href.offset<>0)) or
            (((href.offset<0) or (href.offset>1020) or (href.offset mod 4<>0))) then
            fixref(list,href);
 
-         list.concat(taicpu.op_reg_ref(A_LSI,reg,href));
+         if (href.base<>NR_NO) and (href.index<>NR_NO) then
+           list.concat(taicpu.op_reg_ref(A_LSX,reg,href))
+         else
+           list.concat(taicpu.op_reg_ref(A_LSI,reg,href));
 
          if fromsize<>tosize then
            a_loadfpu_reg_reg(list,fromsize,tosize,reg,reg);
@@ -1198,11 +1201,14 @@ implementation
            InternalError(2020032604);
          href:=ref;
          if assigned(href.symbol) or
-           (href.index<>NR_NO) or
+           ((href.index<>NR_NO) and (href.offset<>0)) or
            (((href.offset<0) or (href.offset>1020) or (href.offset mod 4<>0))) then
            fixref(list,href);
 
-         list.concat(taicpu.op_reg_ref(A_SSI,reg,href));
+         if (href.base<>NR_NO) and (href.index<>NR_NO) then
+           list.concat(taicpu.op_reg_ref(A_SSX,reg,href))
+         else
+           list.concat(taicpu.op_reg_ref(A_SSI,reg,href));
        end;
 
 

compiler/xtensa/ncpuadd.pas

@@ -47,6 +47,7 @@ interface
          procedure second_cmpfloat;override;
          procedure second_addfloat;override;
          procedure second_cmp;
+         function use_fma: boolean;override;
        end;
 
   implementation
@@ -67,6 +68,13 @@ interface
                                TCPUAddNode
 *****************************************************************************}
 
+    function TCPUAddNode.use_fma : boolean;
+      begin
+        Result:=is_single(left.resultdef) and is_single(right.resultdef) and
+          (FPUXTENSA_SINGLE in fpu_capabilities[current_settings.fputype]);
+      end;
+
+
     procedure TCPUAddNode.second_addordinal;
       var
         ophigh: tasmop;

compiler/xtensa/ncpuinl.pas

@@ -33,6 +33,8 @@ unit ncpuinl;
         function first_abs_real: tnode; override;
         procedure second_abs_long; override;
         procedure second_abs_real; override;
+        function first_fma: tnode; override;
+        procedure second_fma; override;
       end;
 
   implementation
@@ -48,6 +50,7 @@ unit ncpuinl;
       hlcgobj,
       pass_2,
       cgbase, cgobj, cgutils,
+      ncal,
       cpubase;
 
     procedure tcpuinlinenode.second_abs_long;
@@ -84,6 +87,86 @@ unit ncpuinl;
       end;
 
 
+    function tcpuinlinenode.first_fma : tnode;
+      begin
+        if is_single(resultdef) then
+          begin
+            expectloc:=LOC_FPUREGISTER;
+            Result:=nil;
+          end
+        else
+          Result:=inherited first_fma;
+      end;
+
+
+    procedure tcpuinlinenode.second_fma;
+      const
+        op : array[false..true] of TAsmOp =
+          (A_MADD,
+           A_MSUB);
+
+      var
+        paraarray : array[1..3] of tnode;
+        i : integer;
+        negproduct : boolean;
+        oppostfix : TOpPostfix;
+        ai: taicpu;
+      begin
+         if is_single(resultdef)and
+           (FPUXTENSA_SINGLE in fpu_capabilities[current_settings.fputype]) then
+           begin
+             negproduct:=false;
+             paraarray[1]:=tcallparanode(tcallparanode(tcallparanode(parameters).nextpara).nextpara).paravalue;
+             paraarray[2]:=tcallparanode(tcallparanode(parameters).nextpara).paravalue;
+             paraarray[3]:=tcallparanode(parameters).paravalue;
+
+             { check if a neg. node can be removed
+               this is possible because changing the sign of
+               a floating point number does not affect its absolute
+               value in any way
+             }
+             if paraarray[1].nodetype=unaryminusn then
+               begin
+                 paraarray[1]:=tunarynode(paraarray[1]).left;
+                 { do not release the unused unary minus node, it is kept and release together with the other nodes,
+                   only no code is generated for it }
+                 negproduct:=not(negproduct);
+               end;
+
+             if paraarray[2].nodetype=unaryminusn then
+               begin
+                 paraarray[2]:=tunarynode(paraarray[2]).left;
+                 { do not release the unused unary minus node, it is kept and release together with the other nodes,
+                   only no code is generated for it }
+                 negproduct:=not(negproduct);
+               end;
+              for i:=1 to 3 do
+               secondpass(paraarray[i]);
+
+             { no memory operand is allowed }
+             for i:=1 to 3 do
+               begin
+                 if not(paraarray[i].location.loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER]) then
+                   hlcg.location_force_fpureg(current_asmdata.CurrAsmList,paraarray[i].location,paraarray[i].resultdef,true);
+               end;
+
+             location_reset(location,LOC_FPUREGISTER,paraarray[1].location.size);
+             location.register:=cg.getfpuregister(current_asmdata.CurrAsmList,location.size);
+
+             hlcg.a_loadfpu_reg_reg(current_asmdata.CurrAsmList,paraarray[3].resultdef,resultdef,
+               paraarray[3].location.register,location.register);
+
+             ai:=taicpu.op_reg_reg_reg(op[negproduct],
+               location.register,paraarray[1].location.register,paraarray[2].location.register);
+             ai.oppostfix:=PF_S;
+             current_asmdata.CurrAsmList.concat(ai);
+
+             cg.maybe_check_for_fpu_exception(current_asmdata.CurrAsmList);
+           end
+         else
+           internalerror(2020112401);
+      end;
+
 
 begin
   cinlinenode:=tcpuinlinenode;

packages/fcl-sound/src/fpwavreader.pas

@@ -96,7 +96,7 @@ begin
   LEtoN(fmt);
   Result := Result and (fmt.ChunkHeader.ID = AUDIO_CHUNK_ID_fmt) and ((fmt.ChunkHeader.Size + 8) >= sizeof(fmt));
   if Result and ((fmt.ChunkHeader.Size + 8) > sizeof(fmt)) then
-    fStream.Seek((fmt.ChunkHeader.Size + 8) - sizeof(fmt), soCurrent);
+    fStream.Seek(Align((fmt.ChunkHeader.Size + 8) - sizeof(fmt), 2), soCurrent);
 end;
 
 function Min(a, b: Integer): Integer;

packages/fcl-sound/tests/data/wav/reader/valid/odd_fmt_size.wav.info.txt

@@ -0,0 +1 @@
+4800 1 8 1

packages/fcl-sound/tests/tcwavreader.pas

@@ -91,6 +91,7 @@ begin
   TestValidFile('44k_stereo_64float.wav');
   TestValidFile('44k_mono_16_tag.wav');
   TestValidFile('euphoric_tape.wav');
+  TestValidFile('odd_fmt_size.wav');
 end;
 
 

packages/qlunits/examples/qlcube.pas

@@ -154,7 +154,7 @@ end;
 
 procedure draw_line(x1,y1,x2,y2: smallint);
 begin
-  sd_line(QCON,-1,x1,y1,x2,y2);
+  sd_line(stdOutputHandle,-1,x1,y1,x2,y2);
 end;
 
 procedure cube_redraw;
@@ -182,14 +182,14 @@ begin
       longint_to_qlfp(@fcubey[i],cy + sarlongint(mulfp(vy,scale),16));
     end;
 
-  sd_clear(QCON,-1);
+  sd_clear(stdOutputHandle,-1);
   for i:=0 to 3 do 
     begin
       e:=(i+1) and 3;
-      sd_line(QCON,-1,@fcubex[i],@fcubey[i],@fcubex[e],@fcubey[e]);
+      sd_line(stdOutputHandle,-1,@fcubex[i],@fcubey[i],@fcubex[e],@fcubey[e]);
       s:=i+4; e:=e+4;
-      sd_line(QCON,-1,@fcubex[s],@fcubey[s],@fcubex[e],@fcubey[e]);
-      sd_line(QCON,-1,@fcubex[i],@fcubey[i],@fcubex[s],@fcubey[s]);
+      sd_line(stdOutputHandle,-1,@fcubex[s],@fcubey[s],@fcubex[e],@fcubey[e]);
+      sd_line(stdOutputHandle,-1,@fcubex[i],@fcubey[i],@fcubex[s],@fcubey[s]);
     end;
 end;
 

rtl/emx/sysutils.pp

@@ -1097,30 +1097,33 @@ asm
  mov ah, 2Ah
  call syscall
 {$IFDEF REGCALL}
- pop eax
+ pop edi
 {$ELSE REGCALL}
  mov edi, SystemTime
 {$ENDIF REGCALL}
- mov ax, cx
- stosw
- xor eax, eax
- mov al, 10
- mul dl
+ xchg ax, cx
  shl eax, 16
  mov al, dh
  stosd
+ mov al, dl
+ shl eax, 16
+ mov al, cl
+ stosd
  push edi
  mov ah, 2Ch
  call syscall
  pop edi
  xor eax, eax
- mov al, cl
- shl eax, 16
  mov al, ch
+ shl eax, 16
+ mov al, cl
  stosd
- mov al, dl
+ xor eax, eax
+ mov al, 10
+ mul dl
  shl eax, 16
  mov al, dh
+ rol eax, 16
  stosd
  pop edi
 end {['eax', 'ecx', 'edx', 'edi']};

rtl/go32v2/sysutils.pp

@@ -47,6 +47,7 @@ implementation
 
 {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
 {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
+{$DEFINE HAS_LOCALTIMEZONEOFFSET}
 
 { Include platform independent implementation part }
 {$i sysutils.inc}
@@ -644,6 +645,8 @@ end;
                               Time Functions
 ****************************************************************************}
 
+{$I tzenv.inc}
+
 Procedure GetLocalTime(var SystemTime: TSystemTime);
 var
   Regs: Registers;
@@ -659,6 +662,7 @@ begin
   SystemTime.Year := Regs.Cx;
   SystemTime.Month := Regs.Dh;
   SystemTime.Day := Regs.Dl;
+  SystemTime.DayOfWeek := Regs.Al;
 end ;
 
 
@@ -666,8 +670,16 @@ end ;
                               Misc Functions
 ****************************************************************************}
 
+const
+  BeepChars: array [1..2] of char = #7'$';
+
 procedure sysBeep;
+var
+  Regs: Registers;
 begin
+  Regs.dx := Ofs (BeepChars);
+  Regs.ah := 9;
+  MsDos (Regs);
 end;
 
 
@@ -915,6 +927,7 @@ end;
 Initialization
   InitExceptions;       { Initialize exceptions. OS independent }
   InitInternational;    { Initialize internationalization settings }
+  InitTZ;
   OnBeep:=@SysBeep;
 Finalization
   FreeTerminateProcs;

rtl/go32v2/v2prt0.as

@@ -38,6 +38,7 @@
         .comm   __stubinfo, 4
         .comm   ___djgpp_base_address, 4
         .comm   ___djgpp_selector_limit, 4
+        .comm   __crt0_startup_flags, 4
         .comm   ___djgpp_stack_limit, 4
         .lcomm  sel_buf, 8
 
@@ -921,10 +922,6 @@ ___v2prt0_start_fs:
 ___bs_count:
         .long   1
 
-        .globl  __crt0_startup_flags
-__crt0_startup_flags:
-        .long   0
-
         .globl  __dos_ds
 __dos_ds:
         .long   0

rtl/linux/riscv64/si_c.inc

@@ -39,7 +39,7 @@ procedure _FPC_rv_enter(at_exit: TProcedure; sp: pptruint);
     initialstkptr:=sp;
     operatingsystem_parameter_argc:=argc;
     operatingsystem_parameter_argv:=argv;
-    operatingsystem_parameter_envp:=@sp[1+argc];
+    operatingsystem_parameter_envp:=@sp[argc+2];
 
     libc_start_main(@PascalMain, argc, argv, libc_init_proc, libc_fini_proc, at_exit, sp);
   end;

rtl/linux/riscv64/si_prc.inc

@@ -31,7 +31,7 @@ procedure _FPC_rv_enter(sp: pptruint);
     initialstkptr:=sp;
     operatingsystem_parameter_argc:=argc;
     operatingsystem_parameter_argv:=@sp[1];
-    operatingsystem_parameter_envp:=@sp[1+argc];
+    operatingsystem_parameter_envp:=@sp[argc+2];
 
     PascalMain;
   end;

rtl/linux/xtensa/si_c.inc

@@ -39,7 +39,7 @@ procedure _FPC_xtensa_enter(at_exit: TProcedure; sp: pptruint);
     initialstkptr:=sp;
     operatingsystem_parameter_argc:=argc;
     operatingsystem_parameter_argv:=argv;
-    operatingsystem_parameter_envp:=@sp[1+argc];
+    operatingsystem_parameter_envp:=@sp[argc+2];
 
     libc_start_main(@PascalMain, argc, argv, libc_init_proc, libc_fini_proc, at_exit, sp);
   end;

rtl/linux/xtensa/si_prc.inc

@@ -31,7 +31,7 @@ procedure _FPC_xtensa_enter(sp: pptruint);
     initialstkptr:=sp;
     operatingsystem_parameter_argc:=argc;
     operatingsystem_parameter_argv:=@sp[1];
-    operatingsystem_parameter_envp:=@sp[1+argc];
+    operatingsystem_parameter_envp:=@sp[argc+2];
 
     PascalMain;
   end;

rtl/msdos/sysutils.pp

@@ -48,6 +48,7 @@ implementation
 
 {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
 {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
+{$DEFINE HAS_LOCALTIMEZONEOFFSET}
 
 {$DEFINE executeprocuni} (* Only 1 byte version of ExecuteProcess is provided by the OS *)
 
@@ -629,6 +630,8 @@ end;
                               Time Functions
 ****************************************************************************}
 
+{$I tzenv.inc}
+
 Procedure GetLocalTime(var SystemTime: TSystemTime);
 var
   Regs: Registers;
@@ -644,6 +647,7 @@ begin
   SystemTime.Year := Regs.Cx;
   SystemTime.Month := Regs.Dh;
   SystemTime.Day := Regs.Dl;
+  SystemTime.DayOfWeek := Regs.Al;
 end ;
 
 
@@ -651,8 +655,16 @@ end ;
                               Misc Functions
 ****************************************************************************}
 
+const
+  BeepChars: array [1..2] of char = #7'$';
+
 procedure sysBeep;
+var
+  Regs: Registers;
 begin
+  Regs.dx := Ofs (BeepChars);
+  Regs.ah := 9;
+  MsDos (Regs);
 end;
 
 
@@ -926,6 +938,7 @@ Initialization
   InitExceptions;       { Initialize exceptions. OS independent }
   InitInternational;    { Initialize internationalization settings }
   OnBeep:=@SysBeep;
+  InitTZ;
 Finalization
   FreeTerminateProcs;
   DoneExceptions;

rtl/objpas/sysutils/syssb.inc

@@ -1,11 +1,11 @@
-{ TStringBuilder }
+{ TGenericStringBuilder }
 
-constructor TStringBuilder.Create;
+constructor TGenericStringBuilder.Create;
 begin
   Create(DefaultCapacity,Maxint);
 end;
 
-constructor TStringBuilder.Create(const AValue: SBString; aCapacity: Integer);
+constructor TGenericStringBuilder.Create(const AValue: SBString; aCapacity: Integer);
 begin
   Create(aCapacity,Maxint);
   if (system.Length(AValue)>0) then
@@ -13,25 +13,25 @@ begin
 end;
 
 
-constructor TStringBuilder.Create(const AValue: SBString; StartIndex, Alength,
+constructor TGenericStringBuilder.Create(const AValue: SBString; StartIndex, Alength,
   aCapacity: Integer);
 begin
   Create(Copy(AValue,StartIndex+1,Alength), aCapacity);
 end;
 
-constructor TStringBuilder.Create(aCapacity, aMaxCapacity: Integer);
+constructor TGenericStringBuilder.Create(aCapacity, aMaxCapacity: Integer);
 begin
   FMaxCapacity:=aMaxCapacity;
   Capacity:=aCapacity;
   FLength:=0;
 end;
 
-constructor TStringBuilder.Create(aCapacity: Integer);
+constructor TGenericStringBuilder.Create(aCapacity: Integer);
 begin
   Create(aCapacity,MaxInt);
 end;
 
-constructor TStringBuilder.Create(const AValue: SBString);
+constructor TGenericStringBuilder.Create(const AValue: SBString);
 begin
   Create(aValue,DefaultCapacity);
 end;
@@ -39,31 +39,31 @@ end;
 
 { Property getter/setter }
 
-function TStringBuilder.GetLength: Integer;
+function TGenericStringBuilder.GetLength: Integer;
 begin
   Result:=FLength;
 end;
 
-function TStringBuilder.GetCapacity: Integer;
+function TGenericStringBuilder.GetCapacity: Integer;
 begin
   Result:=System.Length(FData);
 end;
 
-function TStringBuilder.GetC(Index: Integer): SBChar;
+function TGenericStringBuilder.GetC(Index: Integer): SBChar;
 begin
   CheckNegative(Index,'Index');
   CheckRange(Index,0,Length);
   Result:=FData[Index];
 end;
 
-procedure TStringBuilder.SetC(Index: Integer; AValue: SBChar);
+procedure TGenericStringBuilder.SetC(Index: Integer; AValue: SBChar);
 begin
   CheckNegative(Index,'Index');
   CheckRange(Index,0,Length-1);
   FData[Index]:=AValue;
 end;
 
-procedure TStringBuilder.SetLength(AValue: Integer);
+procedure TGenericStringBuilder.SetLength(AValue: Integer);
 
 begin
   CheckNegative(AValue,'AValue');
@@ -77,7 +77,7 @@ end;
 
 
 
-procedure TStringBuilder.CheckRange(Idx, Count, MaxLen: Integer);
+procedure TGenericStringBuilder.CheckRange(Idx, Count, MaxLen: Integer);
 
 begin
   if (Idx<0) or (Idx+Count>MaxLen) then
@@ -85,7 +85,7 @@ begin
 end;
 
 
-procedure TStringBuilder.CheckNegative(const AValue: Integer;
+procedure TGenericStringBuilder.CheckNegative(const AValue: Integer;
   const AName: SBString);
 
 begin
@@ -95,7 +95,7 @@ end;
 
 {  These do the actual Appending/Inserting }
 
-procedure TStringBuilder.DoAppend(const S: {$IFDEF SBUNICODE}SBString{$ELSE}RawByteString{$ENDIF});
+procedure TGenericStringBuilder.DoAppend(const S: {$IFDEF SBUNICODE}SBString{$ELSE}RawByteString{$ENDIF});
 
 Var
   L,SL : Integer;
@@ -110,7 +110,7 @@ begin
     end;
 end;
 
-procedure TStringBuilder.DoAppend(const AValue: TSBCharArray; Idx, aCount: Integer
+procedure TGenericStringBuilder.DoAppend(const AValue: TSBCharArray; Idx, aCount: Integer
   );
 
 Var
@@ -123,7 +123,7 @@ begin
   Move(AValue[Idx],FData[L],aCount*SizeOf(SBChar));
 end;
 
-procedure TStringBuilder.DoInsert(Index: Integer; const AValue: SBString);
+procedure TGenericStringBuilder.DoInsert(Index: Integer; const AValue: SBString);
 
 Var
   ShiftLen,LV : Integer;
@@ -137,7 +137,7 @@ begin
   Move(AValue[1],FData[Index],LV*SizeOf(SBChar));
 end;
 
-procedure TStringBuilder.DoInsert(Index: Integer; const AValue: TSBCharArray;
+procedure TGenericStringBuilder.DoInsert(Index: Integer; const AValue: TSBCharArray;
   StartIndex, SBCharCount: Integer);
 
 Var
@@ -157,13 +157,13 @@ end;
 
 { Public routines for appending }
 
-function TStringBuilder.Append(const AValue: UInt64): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: UInt64): TGenericStringBuilder;
 begin
   DoAppend(IntToStr(AValue));
   Result:=self;
 end;
 
-function TStringBuilder.Append(const AValue: TSBCharArray): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: TSBCharArray): TGenericStringBuilder;
 
 var
   I,L: Integer;
@@ -180,100 +180,100 @@ begin
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: Single): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Single): TGenericStringBuilder;
 begin
   DoAppend(FloatToStr(AValue));
   Result:=self;
 end;
 
-function TStringBuilder.Append(const AValue: Word): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Word): TGenericStringBuilder;
 begin
   Append(IntToStr(AValue));
   Result:=self;
 end;
 
-function TStringBuilder.Append(const AValue: Cardinal): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Cardinal): TGenericStringBuilder;
 begin
   DoAppend(IntToStr(AValue));
   Result:=self;
 end;
 
-function TStringBuilder.Append(const AValue: SBChar; RepeatCount: Integer
-  ): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: SBChar; RepeatCount: Integer
+  ): TGenericStringBuilder;
 begin
   DoAppend(StringOfChar(AValue,RepeatCount));
   Result:=Self;
 end;
 
 
-function TStringBuilder.Append(const AValue: Shortint): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Shortint): TGenericStringBuilder;
 begin
   DoAppend(IntToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: SBChar): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: SBChar): TGenericStringBuilder;
 begin
   DoAppend(AValue);
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: Currency): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Currency): TGenericStringBuilder;
 begin
   DoAppend(CurrToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: Boolean): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Boolean): TGenericStringBuilder;
 begin
   DoAppend(BoolToStr(AValue, True));
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: Byte): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Byte): TGenericStringBuilder;
 begin
   DoAppend(IntToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: Double): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Double): TGenericStringBuilder;
 begin
   DoAppend(FloatToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: Int64): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Int64): TGenericStringBuilder;
 begin
   DoAppend(IntToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: TObject): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: TObject): TGenericStringBuilder;
 begin
   DoAppend(AValue.ToString);
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: Smallint): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: Smallint): TGenericStringBuilder;
 begin
   DoAppend(IntToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: LongInt): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: LongInt): TGenericStringBuilder;
 begin
   DoAppend(IntToStr(AValue));
   Result:=Self;
 end;
 
-Function TStringBuilder.Append(const AValue: TSBCharArray; StartIndex, SBCharCount: Integer): TStringBuilder;
+Function TGenericStringBuilder.Append(const AValue: TSBCharArray; StartIndex, SBCharCount: Integer): TGenericStringBuilder;
 
 begin
   DoAppend(AValue,StartIndex,SBCharCount);
   Result:=Self;
 end;
 
-Function TStringBuilder.Append(const AValue: SBString; StartIndex, Count: Integer): TStringBuilder;
+Function TGenericStringBuilder.Append(const AValue: SBString; StartIndex, Count: Integer): TGenericStringBuilder;
 
 begin
   CheckRange(StartIndex,Count,System.Length(AValue));
@@ -281,21 +281,21 @@ begin
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const AValue: PSBChar): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: PSBChar): TGenericStringBuilder;
 begin
   DoAppend(AnsiString(AValue));
   Result:=Self;
 end;
 
 {$IFDEF SBUNICODE}
-function TStringBuilder.Append(const AValue: SBString): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: SBString): TGenericStringBuilder;
 begin
   DoAppend(AValue);
   Result:=Self;
 end;
 {$ENDIF}
 
-function TStringBuilder.Append(const AValue: RawByteString): TStringBuilder;
+function TGenericStringBuilder.Append(const AValue: RawByteString): TGenericStringBuilder;
 begin
   {$IFDEF SBUNICODE}
   DoAppend(SBString(AValue));
@@ -305,40 +305,40 @@ begin
   Result:=Self;
 end;
 
-function TStringBuilder.AppendFormat(const Fmt: SBString;
-  const Args: array of const): TStringBuilder;
+function TGenericStringBuilder.AppendFormat(const Fmt: SBString;
+  const Args: array of const): TGenericStringBuilder;
 begin
   DoAppend(Format(Fmt,Args));
   Result:=Self;
 end;
 
-function TStringBuilder.Append(const Fmt: SBString;
-  const Args: array of const): TStringBuilder;
+function TGenericStringBuilder.Append(const Fmt: SBString;
+  const Args: array of const): TGenericStringBuilder;
 begin
   DoAppend(Format(Fmt,Args));
   Result:=Self;
 end;
 
-function TStringBuilder.AppendLine: TStringBuilder;
+function TGenericStringBuilder.AppendLine: TGenericStringBuilder;
 begin
   DoAppend(sLineBreak);
   Result:=Self;
 end;
 
-function TStringBuilder.AppendLine(const AValue: RawByteString): TStringBuilder;
+function TGenericStringBuilder.AppendLine(const AValue: RawByteString): TGenericStringBuilder;
 begin
   DoAppend(AValue);
   Result:=AppendLine();
 end;
 
-procedure TStringBuilder.Clear;
+procedure TGenericStringBuilder.Clear;
 begin
   Length:=0;
   Capacity:=DefaultCapacity;
 end;
 
 
-procedure TStringBuilder.CopyTo(SourceIndex: Integer;
+procedure TGenericStringBuilder.CopyTo(SourceIndex: Integer;
   Var Destination: TSBCharArray; DestinationIndex: Integer; Count: Integer);
 
 begin
@@ -353,7 +353,7 @@ begin
 end;
 
 
-function TStringBuilder.EnsureCapacity(aCapacity: Integer): Integer;
+function TGenericStringBuilder.EnsureCapacity(aCapacity: Integer): Integer;
 begin
   CheckRange(aCapacity,0,MaxCapacity);
   if Capacity<aCapacity then
@@ -361,7 +361,7 @@ begin
   Result:=Capacity;
 end;
 
-function TStringBuilder.Equals(StringBuilder: TStringBuilder): Boolean;
+function TGenericStringBuilder.Equals(StringBuilder: TGenericStringBuilder): Boolean;
 begin
   Result:=(StringBuilder<>nil);
   if Result then
@@ -370,7 +370,7 @@ begin
              and CompareMem(@FData[0],@StringBuilder.FData[0],Length*SizeOf(SBChar));
 end;
 
-procedure TStringBuilder.Grow;
+procedure TGenericStringBuilder.Grow;
 
 var
   NewCapacity: SizeInt;
@@ -382,101 +382,101 @@ begin
   Capacity:=NewCapacity;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: TObject
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: TObject
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,AValue.ToString());
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Int64
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Int64
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,IntToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Single
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Single
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,FloatToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: SBString
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: SBString
+  ): TGenericStringBuilder;
 
 begin
   DoInsert(Index,AValue);
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Word
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Word
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,IntToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Shortint
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Shortint
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index, IntToStr(AValue));
   Result:=Self;
 end;
 
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Currency
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Currency
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,CurrToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: SBChar
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: SBChar
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,AValue);
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Byte
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Byte
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,IntToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Double
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Double
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,FloatToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: LongInt
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: LongInt
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,IntToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Smallint
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Smallint
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,IntToStr(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Boolean
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Boolean
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,BoolToStr(AValue,True));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: SBString;
-  const aRepeatCount: Integer): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: SBString;
+  const aRepeatCount: Integer): TGenericStringBuilder;
 var
   I: Integer;
 begin
@@ -485,43 +485,43 @@ begin
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: TSBCharArray
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: TSBCharArray
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,AValue,0,System.Length(AValue));
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: TSBCharArray;
-  startIndex: Integer; SBCharCount: Integer): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: TSBCharArray;
+  startIndex: Integer; SBCharCount: Integer): TGenericStringBuilder;
 begin
   DoInsert(Index,AValue,StartIndex,SBCharCount);
   Result:=Self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: Cardinal
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: Cardinal
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,IntToStr(AValue));
   Result:=self;
 end;
 
-function TStringBuilder.Insert(Index: Integer; const AValue: UInt64
-  ): TStringBuilder;
+function TGenericStringBuilder.Insert(Index: Integer; const AValue: UInt64
+  ): TGenericStringBuilder;
 begin
   DoInsert(Index,IntToStr(AValue));
   Result:=self;
 end;
 
-procedure TStringBuilder.Shrink;
+procedure TGenericStringBuilder.Shrink;
 
 begin
   if (Capacity div 4)>=Length then
     Capacity:=Capacity div 2;
 end;
 
-function TStringBuilder.Remove(StartIndex: Integer; RemLength: Integer
-  ): TStringBuilder;
+function TGenericStringBuilder.Remove(StartIndex: Integer; RemLength: Integer
+  ): TGenericStringBuilder;
 
 Var
   MoveIndex : Integer;
@@ -540,7 +540,7 @@ begin
   Result:=Self;
 end;
 
-Function TStringBuilder.Replace(const OldValue, NewValue: SBRawString; StartIndex, Count: Integer): TStringBuilder;
+Function TGenericStringBuilder.Replace(const OldValue, NewValue: SBRawString; StartIndex, Count: Integer): TGenericStringBuilder;
 
 var
   Cur : PSBChar;
@@ -587,8 +587,8 @@ begin
   Result:=Self;
 end;
 
-Function TStringBuilder.Replace(const OldChar, NewChar: SBChar; StartIndex,
-  Count: Integer): TStringBuilder;
+Function TGenericStringBuilder.Replace(const OldChar, NewChar: SBChar; StartIndex,
+  Count: Integer): TGenericStringBuilder;
 var
   I : Integer;
   Cur : PSBChar;
@@ -609,18 +609,18 @@ begin
   Result:=Self;
 end;
 
-Function TStringBuilder.Replace(const OldChar, NewChar: SBChar): TStringBuilder;
+Function TGenericStringBuilder.Replace(const OldChar, NewChar: SBChar): TGenericStringBuilder;
 
 begin
   Result:=Replace(OldChar,NewChar,0,Length);
 end;
 
-Function TStringBuilder.Replace(const OldValue, NewValue: SBRawString): TStringBuilder;
+Function TGenericStringBuilder.Replace(const OldValue, NewValue: SBRawString): TGenericStringBuilder;
 begin
   Result:=Replace(OldValue,NewValue,0,Length);
 end;
 
-procedure TStringBuilder.SetCapacity(AValue: Integer);
+procedure TGenericStringBuilder.SetCapacity(AValue: Integer);
 begin
   if (AValue>FMaxCapacity) then
     Raise ERangeError.CreateFmt(SListCapacityError,[AValue]);
@@ -630,12 +630,12 @@ begin
 end;
 
 
-function TStringBuilder.ToString: SBString;
+function TGenericStringBuilder.ToString: SBString;
 begin
   Result:=ToString(0,Length);
 end;
 
-function TStringBuilder.ToString(aStartIndex: Integer; aLength: Integer
+function TGenericStringBuilder.ToString(aStartIndex: Integer; aLength: Integer
   ): SBString;
 begin
   if (aLength=0) then
@@ -650,7 +650,7 @@ begin
     end;
 end;
 
-procedure TStringBuilder.DoReplace(Index: Integer; const Old, New: SBString);
+procedure TGenericStringBuilder.DoReplace(Index: Integer; const Old, New: SBString);
 
 var
   NVLen,OVLen,OLen,Delta,TailStart: Integer;

rtl/objpas/sysutils/syssbh.inc

@@ -1,7 +1,7 @@
 
-  { TStringBuilder }
+  { TGenericStringBuilder }
 
-  TStringBuilder = class
+  TGenericStringBuilder = class
   private
     const
       DefaultCapacity = 64;
@@ -36,66 +36,66 @@
     Constructor Create(const AValue: SBString; aCapacity: Integer);
     Constructor Create(const AValue: SBString; StartIndex: Integer; aLength: Integer; aCapacity: Integer);
 
-    Function Append(const AValue: Boolean): TStringBuilder;
-    Function Append(const AValue: Byte): TStringBuilder;
-    Function Append(const AValue: SBChar): TStringBuilder;
-    Function Append(const AValue: Currency): TStringBuilder;
-    Function Append(const AValue: Double): TStringBuilder;
-    Function Append(const AValue: Smallint): TStringBuilder;
-    Function Append(const AValue: LongInt): TStringBuilder;
-    Function Append(const AValue: Int64): TStringBuilder;
-    Function Append(const AValue: TObject): TStringBuilder;
-    Function Append(const AValue: Shortint): TStringBuilder;
-    Function Append(const AValue: Single): TStringBuilder;
-    Function Append(const AValue: UInt64): TStringBuilder;
-    Function Append(const AValue: TSBCharArray): TStringBuilder;
-    Function Append(const AValue: Word): TStringBuilder;
-    Function Append(const AValue: Cardinal): TStringBuilder;
-    Function Append(const AValue: PSBChar): TStringBuilder;
+    Function Append(const AValue: Boolean): TGenericStringBuilder;
+    Function Append(const AValue: Byte): TGenericStringBuilder;
+    Function Append(const AValue: SBChar): TGenericStringBuilder;
+    Function Append(const AValue: Currency): TGenericStringBuilder;
+    Function Append(const AValue: Double): TGenericStringBuilder;
+    Function Append(const AValue: Smallint): TGenericStringBuilder;
+    Function Append(const AValue: LongInt): TGenericStringBuilder;
+    Function Append(const AValue: Int64): TGenericStringBuilder;
+    Function Append(const AValue: TObject): TGenericStringBuilder;
+    Function Append(const AValue: Shortint): TGenericStringBuilder;
+    Function Append(const AValue: Single): TGenericStringBuilder;
+    Function Append(const AValue: UInt64): TGenericStringBuilder;
+    Function Append(const AValue: TSBCharArray): TGenericStringBuilder;
+    Function Append(const AValue: Word): TGenericStringBuilder;
+    Function Append(const AValue: Cardinal): TGenericStringBuilder;
+    Function Append(const AValue: PSBChar): TGenericStringBuilder;
 {$IFDEF SBUNICODE}
     // Do not use SBRawstring, we need 2 versions in case of unicode
-    Function Append(const AValue: SBString): TStringBuilder;
+    Function Append(const AValue: SBString): TGenericStringBuilder;
 {$ENDIF}
-    Function Append(const AValue: RawByteString): TStringBuilder;
-    Function Append(const AValue: SBChar; RepeatCount: Integer): TStringBuilder;
-    Function Append(const AValue: TSBCharArray; StartIndex: Integer; SBCharCount: Integer): TStringBuilder;
-    Function Append(const AValue: SBString; StartIndex: Integer; Count: Integer): TStringBuilder;
+    Function Append(const AValue: RawByteString): TGenericStringBuilder;
+    Function Append(const AValue: SBChar; RepeatCount: Integer): TGenericStringBuilder;
+    Function Append(const AValue: TSBCharArray; StartIndex: Integer; SBCharCount: Integer): TGenericStringBuilder;
+    Function Append(const AValue: SBString; StartIndex: Integer; Count: Integer): TGenericStringBuilder;
 
-    Function Append(const Fmt: SBString; const Args: array of const): TStringBuilder;
-    Function AppendFormat(const Fmt: SBString; const Args: array of const): TStringBuilder;
-    Function AppendLine: TStringBuilder;
-    Function AppendLine(const AValue: RawByteString): TStringBuilder;
+    Function Append(const Fmt: SBString; const Args: array of const): TGenericStringBuilder;
+    Function AppendFormat(const Fmt: SBString; const Args: array of const): TGenericStringBuilder;
+    Function AppendLine: TGenericStringBuilder;
+    Function AppendLine(const AValue: RawByteString): TGenericStringBuilder;
 
     Procedure Clear;
     Procedure CopyTo(SourceIndex: Integer; Var Destination: TSBCharArray; DestinationIndex: Integer; Count: Integer);
     Function EnsureCapacity(aCapacity: Integer): Integer;
-    Function Equals(StringBuilder: TStringBuilder): Boolean; reintroduce;
+    Function Equals(StringBuilder: TGenericStringBuilder): Boolean; reintroduce;
 
-    Function Insert(Index: Integer; const AValue: Boolean): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: Byte): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: SBChar): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: Currency): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: Double): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: Smallint): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: LongInt): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: TSBCharArray): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: Int64): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: TObject): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: Shortint): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: Single): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: SBString): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: Word): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: Cardinal): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: UInt64): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: SBString; const aRepeatCount: Integer): TStringBuilder;
-    Function Insert(Index: Integer; const AValue: TSBCharArray; startIndex: Integer; SBCharCount: Integer): TStringBuilder;
+    Function Insert(Index: Integer; const AValue: Boolean): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: Byte): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: SBChar): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: Currency): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: Double): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: Smallint): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: LongInt): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: TSBCharArray): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: Int64): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: TObject): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: Shortint): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: Single): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: SBString): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: Word): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: Cardinal): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: UInt64): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: SBString; const aRepeatCount: Integer): TGenericStringBuilder;
+    Function Insert(Index: Integer; const AValue: TSBCharArray; startIndex: Integer; SBCharCount: Integer): TGenericStringBuilder;
 
-    Function Remove(StartIndex: Integer; RemLength: Integer): TStringBuilder;
+    Function Remove(StartIndex: Integer; RemLength: Integer): TGenericStringBuilder;
 
-    Function Replace(const OldChar, NewChar: SBChar): TStringBuilder;
-    Function Replace(const OldChar, NewChar: SBChar; StartIndex: Integer; Count: Integer): TStringBuilder;
-    Function Replace(const OldValue, NewValue: SBRawString): TStringBuilder;
-    Function Replace(const OldValue, NewValue: SBRawString; StartIndex: Integer; Count: Integer): TStringBuilder;
+    Function Replace(const OldChar, NewChar: SBChar): TGenericStringBuilder;
+    Function Replace(const OldChar, NewChar: SBChar; StartIndex: Integer; Count: Integer): TGenericStringBuilder;
+    Function Replace(const OldValue, NewValue: SBRawString): TGenericStringBuilder;
+    Function Replace(const OldValue, NewValue: SBRawString; StartIndex: Integer; Count: Integer): TGenericStringBuilder;
 {$IFDEF SBUNICODE}
     Function ToString: SBString;
 {$ELSE}

rtl/objpas/sysutils/sysstr.inc

@@ -2805,7 +2805,7 @@ function sscanf(const s: string; const fmt : string;const Pointers : array of Po
 {$define TSBCharArray:=Array of SBChar}
 {$define PSBChar:=PAnsiChar}
 {$define SBRAWString:=RawByteString}
-{$define TStringBuilder:=TAnsiStringBuilder}
+{$define TGenericStringBuilder:=TAnsiStringBuilder}
 
 {$i syssb.inc}
 {$undef SBChar}
@@ -2813,7 +2813,7 @@ function sscanf(const s: string; const fmt : string;const Pointers : array of Po
 {$undef TSBCharArray}
 {$undef PSBChar}
 {$undef SBRAWString}
-{$undef TStringBuilder}
+{$undef TGenericStringBuilder}
 
 // Unicode version declaration
 
@@ -2823,14 +2823,14 @@ function sscanf(const s: string; const fmt : string;const Pointers : array of Po
 {$define TSBCharArray:=Array of SBChar}
 {$define PSBChar:=PWideChar}
 {$define SBRAWString:=UnicodeString}
-{$define TStringBuilder:=TUnicodeStringBuilder}
+{$define TGenericStringBuilder:=TUnicodeStringBuilder}
 {$i syssb.inc}
 {$undef SBChar}
 {$undef SBString}
 {$undef TSBCharArray}
 {$undef PSBChar}
 {$undef SBRAWString}
-{$undef TStringBuilder}
+{$undef TGenericStringBuilder}
 {$undef SBUNICODE}
 
 

rtl/objpas/sysutils/sysstrh.inc

@@ -307,7 +307,7 @@ Type
 {$define TSBCharArray:=Array of SBChar}
 {$define PSBChar:=PAnsiChar}
 {$define SBRAWString:=RawByteString}
-{$define TStringBuilder:=TAnsiStringBuilder}
+{$define TGenericStringBuilder:=TAnsiStringBuilder}
 
 {$i syssbh.inc}
 {$undef SBChar}
@@ -315,7 +315,7 @@ Type
 {$undef TSBCharArray}
 {$undef PSBChar}
 {$undef SBRAWString}
-{$undef TStringBuilder}
+{$undef TGenericStringBuilder}
 
 // Unicode version implementation
 
@@ -325,14 +325,14 @@ Type
 {$define TSBCharArray:=Array of SBChar}
 {$define PSBChar:=PWideChar}
 {$define SBRAWString:=UnicodeString}
-{$define TStringBuilder:=TUnicodeStringBuilder}
+{$define TGenericStringBuilder:=TUnicodeStringBuilder}
 {$i syssbh.inc}
 {$undef SBChar}
 {$undef SBString}
 {$undef TSBCharArray}
 {$undef PSBChar}
 {$undef SBRAWString}
-{$undef TStringBuilder}
+{$undef TGenericStringBuilder}
 {$undef SBUNICODE}
 
 Type

rtl/objpas/sysutils/tzenv.inc

@@ -0,0 +1,926 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2020 by Tomas Hajny,
+    member of the Free Pascal development team.
+
+    Support routines for calculation of local timezone and DST time
+    offset based on information provided in the environment variable TZ.
+
+    There are various ways for specifying the timezone details using the
+    TZ variable. The more information is provided, the better results.
+    As an example, the following setting provides full information
+    including details for DST on/off switching date and time:
+    TZ=CET-1CEST,3,-1,0,7200,10,-1,0,10800,3600
+    (CET timezone is 1 hour in advance from UTC, there is DST called CEST,
+    DST starts on the last Sunday of March at 2am and finishes on the last
+    Sunday of October at 3am, the DST difference is 1 hour).
+    However, this is by no means the only supported syntax.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+
+type
+ DSTSpecType = (DSTMonthWeekDay, DSTMonthDay, DSTJulian, DSTJulianX);
+
+const
+  TZEnvName = 'TZ';
+{$IFDEF OS2}
+  EMXTZEnvName = 'EMXTZ';
+{$ENDIF OS2}
+  MaxSecond = 86399;
+(* The following values differing from the defaults *)
+(* below are not used at the moment. *)
+  USDSTStartMonth = 3;
+  USDSTStartWeek = 2;
+  USDSTEndMonth = 11;
+  USDSTEndWeek = 1;
+  EUDSTStartMonth = 3;
+  EUDSTStartWeek = -1;
+(* Initialized to default values, updated after a call to InitTZ *)
+  TZName: string = '';
+  TZDSTName: string = '';
+  TZOffset: longint = 0;
+  TZOffsetMin: longint = 0;
+  DSTOffset: longint = 0;
+  DSTOffsetMin: longint = 0;
+  DSTStartMonth: byte = 4;
+  DSTStartWeek: shortint = 1;
+  DSTStartDay: word = 0;
+  DSTStartSec: cardinal = 7200;
+  DSTEndMonth: byte = 10;
+  DSTEndWeek: shortint = -1;
+  DSTEndDay: word = 0;
+  DSTEndSec: cardinal = 10800;
+  DSTStartSpecType: DSTSpecType = DSTMonthWeekDay;
+  DSTEndSpecType: DSTSpecType = DSTMonthWeekDay;
+
+(* The following variables are initialized after a call to InitTZ. *)
+var
+  RealDSTStartMonth, RealDSTStartDay, RealDSTEndMonth, RealDSTEndDay: byte;
+
+const
+  MonthEnds: array [1..12] of word =
+                     (31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365);
+
+
+function LeapDay (Year: word): byte; inline;
+begin
+  if IsLeapYear (Year) then
+   LeapDay := 1
+  else
+   LeapDay := 0;
+end;
+
+
+function FirstDay (MM: byte; Y: word; Mo: word; D: word; WD: word): byte;
+                                                                        inline;
+var
+  DD: longint;
+begin
+  if MM < Mo then
+   begin
+    DD := D + MonthEnds [Pred (Mo)];
+    if MM > 1 then
+     Dec (DD, MonthEnds [Pred (MM)]);
+    if (MM <= 2) and (Mo > 2) then
+     Inc (DD, LeapDay (Y));
+   end
+  else
+   if MM > Mo then
+    begin
+     DD := - MonthDays [false, Mo] + D - MonthEnds [Pred (MM)]
+                                                              + MonthEnds [Mo];
+     if (Mo <= 2) and (MM > 2) then
+      Dec (DD, LeapDay (Y));
+    end
+   else
+(* M = MM *)
+    DD := D;
+  DD := WD - DD mod 7 + 1;
+  if DD < 0 then
+   FirstDay := DD + 7
+  else
+   FirstDay := DD mod 7;
+end;
+
+
+procedure UpdateTimeWithOffset (var SystemTime: TSystemTime; Offset: longint);
+                                                                        inline;
+var
+  Y: longint;
+  Mo: longint;
+  D: longint;
+  WD: word;
+  H: longint;
+  Mi: longint;
+begin
+  with SystemTime do
+   begin
+    Y := Year;
+    Mo := Month;
+    D := Day;
+    WD := DayOfWeek;
+    H := Hour;
+    Mi := Minute;
+   end;
+  Mi := Mi + (Offset mod 60);
+  H := H + (Offset div 60);
+  if Mi < 0 then
+   begin
+    Inc (Mi, 60);
+    Dec (H);
+   end;
+  if H < 0 then
+   begin
+    Inc (H, 24);
+    if WD = 0 then
+     WD := 6
+    else
+     Dec (WD);
+    if D = 1 then
+     begin
+      if Mo = 1 then
+       begin
+        Dec (Y);
+        Mo := 12;
+       end
+      else
+       Dec (Mo);
+      D := MonthDays [IsLeapYear (Y), Mo];
+     end
+    else
+     Dec (D);
+   end
+  else
+   begin
+    if Mi > 59 then
+     begin
+      Dec (Mi, 60);
+      Inc (H);
+     end;
+    if H > 23 then
+     begin
+      Dec (H, 24);
+      if WD = 6 then
+       WD := 0
+      else
+       Inc (WD);
+      if D = MonthDays [IsLeapYear (Y), Mo] then
+       begin
+        D := 1;
+        if Mo = 12 then
+         begin
+          Inc (Y);
+          Mo := 1;
+         end
+        else
+         Inc (Mo);
+       end
+      else
+       Inc (D);
+     end;
+   end;
+  with SystemTime do
+   begin
+    Year := Y;
+    Month := Mo;
+    Day := D;
+    DayOfWeek := WD;
+    Hour := H;
+    Minute := Mi;
+   end;
+end;
+
+
+function InDST (const Time: TSystemTime; const InputIsUTC: boolean): boolean;
+var
+  AfterDSTStart, BeforeDSTEnd: boolean;
+  Y: longint;
+  Mo: longint;
+  D: longint;
+  WD: longint;
+  Second: longint;
+begin
+ InDST := false;
+ if DSTOffset <> TZOffset then
+  begin
+   Second := longint (Time.Hour) * 3600 + Time.Minute * 60 + Time.Second;
+   Y := Time.Year;
+   Mo := Time.Month;
+   D := Time.Day;
+   if InputIsUTC and (TZOffset <> 0) then
+    begin
+     Second := Second - TZOffset;
+     if Second < 0 then
+      begin
+       Second := Second + MaxSecond + 1;
+       if D = 1 then
+        begin
+         if Mo = 1 then
+          begin
+           Dec (Y);
+           Mo := 12;
+          end
+         else
+          Dec (Mo);
+         D := MonthDays [IsLeapYear (Y), Mo];
+        end
+       else
+        Dec (D);
+      end
+     else
+      if Second > MaxSecond then
+       begin
+        Second := Second - MaxSecond - 1;
+        if D = MonthDays [IsLeapYear (Y), Mo] then
+         begin
+          D := 1;
+          if Mo = 12 then
+           begin
+            Inc (Y);
+            Mo := 1;
+           end
+          else
+           Inc (Mo);
+         end
+        else
+         Inc (D);
+       end;
+    end;
+   if Mo < RealDSTStartMonth then
+    AfterDSTStart := false
+   else
+    if Mo > RealDSTStartMonth then
+     AfterDSTStart := true
+    else
+     if D < RealDSTStartDay then
+      AfterDSTStart := false
+     else
+      if D > RealDSTStartDay then
+       AfterDSTStart := true
+      else
+       AfterDSTStart := Second > DSTStartSec;
+   if Mo > RealDSTEndMonth then
+    BeforeDSTEnd := false
+   else
+    if Mo < RealDSTEndMonth then
+     BeforeDSTEnd := true
+    else
+     if D > RealDSTEndDay then
+      BeforeDSTEnd := false
+     else
+      if D < RealDSTEndDay then
+       BeforeDSTEnd := true
+      else
+       BeforeDSTEnd := Second < DSTEndSec;
+   InDST := AfterDSTStart and BeforeDSTEnd;
+  end;
+end;
+
+
+function InDST: boolean; inline;
+var
+  SystemTime: TSystemTime;
+begin
+ InDST := false;
+ if DSTOffset <> TZOffset then
+  begin
+   GetLocalTime (SystemTime);
+   InDST := InDST (SystemTime, false);
+  end;
+end;
+
+
+procedure InitTZ0; inline;
+var
+  TZ, S: string;
+  I, J: byte;
+  Err: longint;
+  GnuFmt: boolean;
+  ADSTStartMonth: byte;
+  ADSTStartWeek: shortint;
+  ADSTStartDay: word;
+  ADSTStartSec: cardinal;
+  ADSTEndMonth: byte;
+  ADSTEndWeek: shortint;
+  ADSTEndDay: word;
+  ADSTEndSec: cardinal;
+  ADSTStartSpecType: DSTSpecType;
+  ADSTEndSpecType: DSTSpecType;
+  ADSTChangeSec: cardinal;
+
+  function ParseOffset (OffStr: string): longint;
+  (* Parse time offset given as [-|+]HH[:MI[:SS]] and return in seconds *)
+  var
+    TZShiftHH, TZShiftDir: shortint;
+    TZShiftMI, TZShiftSS: byte;
+    N1, N2: byte;
+  begin
+    TZShiftHH := 0;
+    TZShiftMI := 0;
+    TZShiftSS := 0;
+    TZShiftDir := 1;
+    N1 := 1;
+    while (N1 <= Length (OffStr)) and (OffStr [N1] <> ':') do
+     Inc (N1);
+    Val (Copy (OffStr, 1, Pred (N1)), TZShiftHH, Err);
+    if (Err = 0) and (TZShiftHH >= -24) and (TZShiftHH <= 23) then
+     begin
+(* Normalize the hour offset to -12..11 if necessary *)
+      if TZShiftHH > 11 then
+       Dec (TZShiftHH, 24) else
+      if TZShiftHH < -12 then
+       Inc (TZShiftHH, 24);
+      if TZShiftHH < 0 then
+       TZShiftDir := -1;
+      if (N1 <= Length (OffStr)) then
+       begin
+        N2 := Succ (N1);
+        while (N2 <= Length (OffStr)) and (OffStr [N2] <> ':') do
+         Inc (N2);
+        Val (Copy (OffStr, Succ (N1), N2 - N1), TZShiftMI, Err);
+         if (Err = 0) and (TZShiftMI <= 59) then
+          begin
+           if (N2 <= Length (OffStr)) then
+            begin
+             Val (Copy (OffStr, Succ (N2), Length (OffStr) - N2), TZShiftSS, Err);
+             if (Err <> 0) or (TZShiftSS > 59) then
+              TZShiftSS := 0;
+            end
+          end
+         else
+          TZShiftMI := 0;
+       end;
+     end
+    else
+     TZShiftHH := 0;
+    ParseOffset := longint (TZShiftHH) * 3600 +
+                           TZShiftDir * (longint (TZShiftMI) * 60 + TZShiftSS);
+  end;
+
+begin
+  TZ := GetEnvironmentVariable (TZEnvName);
+{$IFDEF OS2}
+  if TZ = '' then
+   TZ := GetEnvironmentVariable (EMXTZEnvName);
+{$ENDIF OS2}
+  if TZ <> '' then
+   begin
+    TZ := Upcase (TZ);
+(* Timezone name *)
+    I := 1;
+    while (I <= Length (TZ)) and (TZ [I] in ['A'..'Z']) do
+     Inc (I);
+    TZName := Copy (TZ, 1, Pred (I));
+    if I <= Length (TZ) then
+     begin
+(* Timezone shift *)
+      J := Succ (I);
+      while (J <= Length (TZ)) and not (TZ [J] in ['A'..'Z']) do
+       Inc (J);
+      TZOffset := ParseOffset (Copy (TZ, I, J - I));
+(* DST timezone name *)
+      I := J;
+      while (J <= Length (TZ)) and (TZ [J] in ['A'..'Z']) do
+       Inc (J);
+      if J > I then
+       begin
+        TZDSTName := Copy (TZ, I, J - I);
+(* DST timezone name provided; if equal to the standard timezone  *)
+(* name then DSTOffset is set to be equal to TZOffset by default, *)
+(* otherwise it is set to TZOffset - 3600 seconds.                *)
+        if TZDSTName <> TZName then
+         DSTOffset := -3600 + TZOffset
+        else
+         DSTOffset := TZOffset;
+       end
+      else
+       begin
+        TZDSTName := TZName;
+(* No DST timezone name provided => DSTOffset is equal to TZOffset *)
+        DSTOffset := TZOffset;
+       end;
+      if J <= Length (TZ) then
+       begin
+(* Check if DST offset is specified here;   *)
+(* if not, default value set above is used. *)
+        if TZ [J] <> ',' then
+         begin
+          I := J;
+          Inc (J);
+          while (J <= Length (TZ)) and (TZ [J] <> ',') do
+           Inc (J);
+          DSTOffset := ParseOffset (Copy (TZ, I, J - I));
+         end;
+        if J < Length (TZ) then
+         begin
+          Inc (J);
+(* DST switching details *)
+          case TZ [J] of
+           'M':
+            begin
+(* Mmonth.week.dayofweek[/StartHour] *)
+             ADSTStartSpecType := DSTMonthWeekDay;
+             if J >= Length (TZ) then
+              Exit;
+             Inc (J);
+             I := J;
+             while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
+              Inc (J);
+             if (J >= Length (TZ)) or (TZ [J] <> '.') then
+              Exit;
+             Val (Copy (TZ, I, J - I), ADSTStartMonth, Err);
+             if (Err > 0) or (ADSTStartMonth > 12) then
+              Exit;
+             Inc (J);
+             I := J;
+             while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
+              Inc (J);
+             if (J >= Length (TZ)) or (TZ [J] <> '.') then
+              Exit;
+             Val (Copy (TZ, I, J - I), ADSTStartWeek, Err);
+             if (Err > 0) or (ADSTStartWeek < 1) or (ADSTStartWeek > 5) then
+              Exit;
+             Inc (J);
+             I := J;
+             while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do
+              Inc (J);
+             Val (Copy (TZ, I, J - I), ADSTStartDay, Err);
+             if (Err > 0) or (ADSTStartDay > 6) or (J >= Length (TZ)) then
+              Exit;
+             if TZ [J] = '/' then
+              begin
+               Inc (J);
+               I := J;
+               while (J <= Length (TZ)) and (TZ [J] <> ',') do
+                Inc (J);
+               Val (Copy (TZ, I, J - I), ADSTStartSec, Err);
+               if (Err > 0) or (ADSTStartSec > MaxSecond) or (J >= Length (TZ))
+                                                                           then
+                Exit
+               else
+                ADSTStartSec := ADSTStartSec * 3600;
+              end
+             else
+              (* Use the preset default *)
+              ADSTStartSec := DSTStartSec;
+             Inc (J);
+            end;
+           'J':
+            begin
+(* Jjulianday[/StartHour] *)
+             ADSTStartSpecType := DSTJulianX;
+             if J >= Length (TZ) then
+              Exit;
+             Inc (J);
+             I := J;
+             while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do
+              Inc (J);
+             Val (Copy (TZ, I, J - I), ADSTStartDay, Err);
+             if (Err > 0) or (ADSTStartDay = 0) or (ADSTStartDay > 365)
+                                                     or (J >= Length (TZ)) then
+              Exit;
+             if TZ [J] = '/' then
+              begin
+               Inc (J);
+               I := J;
+               while (J <= Length (TZ)) and (TZ [J] <> ',') do
+                Inc (J);
+               Val (Copy (TZ, I, J - I), ADSTStartSec, Err);
+               if (Err > 0) or (ADSTStartSec > MaxSecond) or (J >= Length (TZ))
+                                                                           then
+                Exit
+               else
+                ADSTStartSec := ADSTStartSec * 3600;
+              end
+             else
+              (* Use the preset default *)
+              ADSTStartSec := DSTStartSec;
+             Inc (J);
+            end
+          else
+           begin
+(* Check the used format first - GNU libc / GCC / EMX expect                 *)
+(* "NameOffsetDstname[Dstoffset],Start[/StartHour],End[/EndHour]";           *)
+(* if more than one comma (',') is found, the following format is assumed:   *)
+(* "NameOffsetDstname[Dstoffset],StartMonth,StartWeek,StartDay,StartSecond,  *)
+(*                         EndMonth,EndWeek,EndDay,EndSecond,DSTDifference". *)
+            I := J;
+            while (J <= Length (TZ)) and (TZ [J] <> ',') do
+             Inc (J);
+            S := Copy (TZ, I, J - I);
+            if J < Length (TZ) then
+             begin
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              GnuFmt := J > Length (TZ);
+             end
+            else
+             Exit;
+            if GnuFmt then
+             begin
+              ADSTStartSpecType := DSTJulian;
+              J := Pos ('/', S);
+              if J = 0 then
+               begin
+                Val (S, ADSTStartDay, Err);
+                if (Err > 0) or (ADSTStartDay > 365) then
+                 Exit;
+                (* Use the preset default *)
+                ADSTStartSec := DSTStartSec;
+               end
+              else
+               begin
+                if J = Length (S) then
+                 Exit;
+                Val (Copy (S, 1, Pred (J)), ADSTStartDay, Err);
+                if (Err > 0) or (ADSTStartDay > 365) then
+                 Exit;
+                Val (Copy (S, Succ (J), Length (S) - J), ADSTStartSec, Err);
+                if (Err > 0) or (ADSTStartSec > MaxSecond) then
+                 Exit
+                else
+                 ADSTStartSec := ADSTStartSec * 3600;
+               end;
+              J := I;
+             end
+            else
+             begin
+              Val (S, ADSTStartMonth, Err);
+              if (Err > 0) or (ADSTStartMonth > 12) then
+               Exit;
+              Val (Copy (TZ, I, J - I), ADSTStartWeek, Err);
+              if (Err > 0) or (ADSTStartWeek < -1) or (ADSTStartWeek > 5) or
+                                                        (J >= Length (TZ)) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTStartDay, Err);
+              if (DSTStartWeek = 0) then
+               begin
+                if (Err > 0) or (ADSTStartDay < 1) or (ADSTStartDay > 31)
+                  or (ADSTStartDay > 30) and (ADSTStartMonth in [4, 6, 9, 11])
+                           or (ADSTStartMonth = 2) and (ADSTStartDay > 29) then
+                 Exit;
+                ADSTStartSpecType := DSTMonthDay;
+               end
+              else
+               begin
+                if (Err > 0) or (ADSTStartDay > 6) then
+                 Exit;
+                ADSTStartSpecType := DSTMonthWeekDay;
+               end;
+              if J >= Length (TZ) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTStartSec, Err);
+              if (Err > 0) or (ADSTStartSec > MaxSecond) or
+                                                        (J >= Length (TZ)) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTEndMonth, Err);
+              if (Err > 0) or (ADSTEndMonth > 12) or (J >= Length (TZ)) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTEndWeek, Err);
+              if (Err > 0) or (ADSTEndWeek < -1) or (ADSTEndWeek > 5)
+                                                     or (J >= Length (TZ)) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTEndDay, Err);
+              if (DSTEndWeek = 0) then
+               begin
+                if (Err > 0) or (ADSTEndDay < 1) or (ADSTEndDay > 31)
+                   or (ADSTEndDay > 30) and (ADSTEndMonth in [4, 6, 9, 11])
+                               or (ADSTEndMonth = 2) and (ADSTEndDay > 29) then
+                 Exit;
+                ADSTEndSpecType := DSTMonthDay;
+               end
+              else
+               begin
+                if (Err > 0) or (ADSTEndDay > 6) then
+                 Exit;
+                ADSTEndSpecType := DSTMonthWeekDay;
+               end;
+              if J >= Length (TZ) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTEndSec, Err);
+              if (Err > 0) or (ADSTEndSec > MaxSecond) or
+                                                        (J >= Length (TZ)) then
+               Exit;
+              Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTChangeSec, Err);
+              if (Err = 0) and (ADSTChangeSec < 86400) then
+               begin
+(* Format complete, all checks successful => accept the parsed values. *)
+                DSTStartMonth := ADSTStartMonth;
+                DSTStartWeek := ADSTStartWeek;
+                DSTStartDay := ADSTStartDay;
+                DSTStartSec := ADSTStartSec;
+                DSTEndMonth := ADSTEndMonth;
+                DSTEndWeek := ADSTEndWeek;
+                DSTEndDay := ADSTEndDay;
+                DSTEndSec := ADSTEndSec;
+                DSTStartSpecType := ADSTStartSpecType;
+                DSTEndSpecType := ADSTEndSpecType;
+                DSTOffset := TZOffset - ADSTChangeSec;
+               end;
+(* Parsing finished *)
+              Exit;
+             end;
+           end;
+          end;
+(* GnuFmt - DST end specification *)
+          if TZ [J] = 'M' then
+           begin
+(* Mmonth.week.dayofweek *)
+            ADSTEndSpecType := DSTMonthWeekDay;
+            if J >= Length (TZ) then
+             Exit;
+            Inc (J);
+            I := J;
+            while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
+             Inc (J);
+            if (J >= Length (TZ)) or (TZ [J] <> '.') then
+             Exit;
+            Val (Copy (TZ, I, J - I), ADSTEndMonth, Err);
+            if (Err > 0) or (ADSTEndMonth > 12) then
+             Exit;
+            Inc (J);
+            I := J;
+            while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
+             Inc (J);
+            if (J >= Length (TZ)) or (TZ [J] <> '.') then
+             Exit;
+            Val (Copy (TZ, I, J - I), ADSTEndWeek, Err);
+            if (Err > 0) or (ADSTEndWeek < 1) or (ADSTEndWeek > 5) then
+             Exit;
+            Inc (J);
+            I := J;
+            while (J <= Length (TZ)) and (TZ [J] <> '/') do
+             Inc (J);
+            Val (Copy (TZ, I, J - I), ADSTEndDay, Err);
+            if (Err > 0) or (ADSTEndDay > 6) then
+             Exit;
+           end
+          else
+           begin
+            if TZ [J] = 'J' then
+             begin
+(* Jjulianday *)
+              if J = Length (TZ) then
+               Exit;
+              Inc (J);
+              ADSTEndSpecType := DSTJulianX
+             end
+            else
+             ADSTEndSpecType := DSTJulian;
+            if J >= Length (TZ) then
+             Exit;
+            Inc (J);
+            I := J;
+            while (J <= Length (TZ)) and (TZ [J] <> '/') do
+             Inc (J);
+            Val (Copy (TZ, I, J - I), ADSTEndDay, Err);
+            if (Err > 0) or (ADSTEndDay = 0) and (ADSTEndSpecType = DSTJulianX)
+                                                     or (ADSTEndDay > 365) then
+             Exit;
+           end;
+          if (J <= Length (TZ)) and (TZ [J] = '/') then
+           begin
+            if J = Length (TZ) then
+             Exit;
+            Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTEndSec, Err);
+            if (Err > 0) or (ADSTEndSec > MaxSecond) then
+             Exit
+            else
+             ADSTEndSec := ADSTEndSec * 3600;
+           end
+          else
+           (* Use the preset default *)
+           ADSTEndSec := DSTEndSec;
+
+(* Format complete, all checks successful => accept the parsed values. *)
+         if ADSTStartSpecType = DSTMonthWeekDay then
+          begin
+           DSTStartMonth := ADSTStartMonth;
+           DSTStartWeek := ADSTStartWeek;
+          end;
+         DSTStartDay := ADSTStartDay;
+         DSTStartSec := ADSTStartSec;
+         if ADSTStartSpecType = DSTMonthWeekDay then
+          begin
+           DSTEndMonth := ADSTEndMonth;
+           DSTEndWeek := ADSTEndWeek;
+          end;
+          DSTEndDay := ADSTEndDay;
+          DSTEndSec := ADSTEndSec;
+          DSTStartSpecType := ADSTStartSpecType;
+          DSTEndSpecType := ADSTEndSpecType;
+         end;
+       end
+      else
+       DSTOffset := -3600 + TZOffset;
+     end;
+   end;
+end;
+
+procedure InitTZ;
+var
+  L: longint;
+  SystemTime: TSystemTime;
+  Y: word absolute SystemTime.Year;
+  Mo: word absolute SystemTime.Month;
+  D: word absolute SystemTime.Day;
+  WD: word absolute SystemTime.DayOfWeek;
+begin
+  InitTZ0;
+  TZOffsetMin := TZOffset div 60;
+  DSTOffsetMin := DSTOffset div 60;
+
+  if DSTOffset <> TZOffset then
+   begin
+    GetLocalTime (SystemTime);
+    if (DSTStartSpecType = DSTMonthWeekDay) or (DSTStartSpecType = DSTMonthDay)
+                                                                           then
+     begin
+      RealDSTStartMonth := DSTStartMonth;
+      if DSTStartSpecType = DSTMonthDay then
+       RealDSTStartDay := DSTStartDay
+      else
+       begin
+        RealDSTStartDay := FirstDay (DSTStartMonth, Y, Mo, D, WD);
+        if (DSTStartWeek >= 1) and (DSTStartWeek <= 4) then
+         if DSTStartDay < RealDSTStartDay then
+          RealDSTStartDay := DSTStartWeek * 7 + DSTStartDay - RealDSTStartDay
+                                                                            + 1
+         else
+          RealDSTStartDay := Pred (DSTStartWeek) * 7 + DSTStartDay
+                                                          - RealDSTStartDay + 1
+        else
+(* Last week in month *)
+         begin
+          RealDSTStartDay := RealDSTStartDay
+                                    + MonthDays [false, RealDSTStartMonth] - 1;
+          if RealDSTStartMonth = 2 then
+           Inc (RealDSTStartDay, LeapDay (Y));
+          RealDSTStartDay := RealDSTStartDay mod 7;
+          if RealDSTStartDay < DSTStartDay then
+           RealDSTStartDay := RealDSTStartDay + 7 - DSTStartDay
+          else
+           RealDSTStartDay := RealDSTStartDay - DSTStartDay;
+          RealDSTStartDay := MonthDays [false, RealDSTStartMonth]
+                                                             - RealDSTStartDay;
+         end;
+       end;
+     end
+    else
+     begin
+(* Julian day *)
+      L := DSTStartDay;
+      if (DSTStartSpecType = DSTJulian) then
+(* 0-based *)
+       if (L + LeapDay (Y) <= 59) then
+        Inc (L)
+       else
+        L := L + 1 - LeapDay (Y);
+      if L <= 31 then
+       begin
+        RealDSTStartMonth := 1;
+        RealDSTStartDay := L;
+       end
+      else
+       if (L <= 59) or
+                (DSTStartSpecType = DSTJulian) and (L - LeapDay (Y) <= 59) then
+        begin
+         RealDSTStartMonth := 2;
+         RealDSTStartDay := DSTStartDay - 31;
+        end
+       else
+        begin
+         RealDSTStartMonth := 3;
+         while (RealDSTStartMonth < 12) and (MonthEnds [RealDSTStartMonth] > L)
+                                                                             do
+          Inc (RealDSTStartMonth);
+         RealDSTStartDay := L - MonthEnds [Pred (RealDSTStartMonth)];
+        end;
+     end;
+
+    if (DSTEndSpecType = DSTMonthWeekDay) or (DSTEndSpecType = DSTMonthDay) then
+     begin
+      RealDSTEndMonth := DSTEndMonth;
+      if DSTEndSpecType = DSTMonthDay then
+       RealDSTEndDay := DSTEndDay
+      else
+       begin
+        RealDSTEndDay := FirstDay (DSTEndMonth, Y, Mo, D, WD);
+        if (DSTEndWeek >= 1) and (DSTEndWeek <= 4) then
+         if DSTEndDay < RealDSTEndDay then
+          RealDSTEndDay := DSTEndWeek * 7 + DSTEndDay - RealDSTEndDay + 1
+         else
+          RealDSTEndDay := Pred (DSTEndWeek) * 7 + DSTEndDay - RealDSTEndDay
+                                                                            + 1
+        else
+(* Last week in month *)
+         begin
+          RealDSTEndDay := RealDSTEndDay + MonthDays [false, RealDSTEndMonth]
+                                                                           - 1;
+          if RealDSTEndMonth = 2 then
+           Inc (RealDSTEndDay, LeapDay (Y));
+          RealDSTEndDay := RealDSTEndDay mod 7;
+          if RealDSTEndDay < DSTEndDay then
+           RealDSTEndDay := RealDSTEndDay + 7 - DSTEndDay
+          else
+           RealDSTEndDay := RealDSTEndDay - DSTEndDay;
+          RealDSTEndDay := MonthDays [false, RealDSTEndMonth] - RealDSTEndDay;
+         end;
+       end;
+     end
+    else
+     begin
+(* Julian day *)
+      L := DSTEndDay;
+      if (DSTEndSpecType = DSTJulian) then
+(* 0-based *)
+       if (L + LeapDay (Y) <= 59) then
+        Inc (L)
+       else
+        L := L + 1 - LeapDay (Y);
+      if L <= 31 then
+       begin
+        RealDSTEndMonth := 1;
+        RealDSTEndDay := L;
+       end
+      else
+       if (L <= 59) or
+                  (DSTEndSpecType = DSTJulian) and (L - LeapDay (Y) <= 59) then
+        begin
+         RealDSTEndMonth := 2;
+         RealDSTEndDay := DSTEndDay - 31;
+        end
+       else
+        begin
+         RealDSTEndMonth := 3;
+         while (RealDSTEndMonth < 12) and (MonthEnds [RealDSTEndMonth] > L) do
+          Inc (RealDSTEndMonth);
+         RealDSTEndDay := L - MonthEnds [Pred (RealDSTEndMonth)];
+        end;
+     end;
+   end;
+end;
+
+{$IFNDEF HAS_DUAL_TZHANDLING}
+function GetUniversalTime (var SystemTime: TSystemTime): boolean;
+begin
+  GetLocalTime (SystemTime);
+  UpdateTimeWithOffset (SystemTime, GetLocalTimeOffset);
+  GetUniversalTime := true;
+end;
+
+function GetLocalTimeOffset: integer;
+begin
+  if InDST then
+   GetLocalTimeOffset := DSTOffsetMin
+  else
+   GetLocalTimeOffset := TZOffsetMin;
+end;
+{$ENDIF HAS_DUAL_TZHANDLING}
+
+
+function GetLocalTimeOffset(const DateTime: TDateTime; const InputIsUTC: boolean; out Offset: integer): boolean;
+var
+  SystemTime: TSystemTime;
+begin
+  DateTimeToSystemTime (DateTime, SystemTime);
+  if InDST (SystemTime, InputIsUTC) then
+   Offset := DSTOffsetMin
+  else
+   Offset := TZOffsetMin;
+  GetLocalTimeOffset := true;
+end;

rtl/os2/sysutils.pp

@@ -56,6 +56,7 @@ threadvar
 {$DEFINE FPC_FEXPAND_GETENV_PCHAR}
 {$DEFINE HAS_GETTICKCOUNT}
 {$DEFINE HAS_GETTICKCOUNT64}
+{$DEFINE HAS_LOCALTIMEZONEOFFSET}
 
 { Include platform independent implementation part }
 {$i sysutils.inc}
@@ -549,6 +550,21 @@ end;
                               Time Functions
 ****************************************************************************}
 
+{$DEFINE HAS_DUAL_TZHANDLING}
+{$I tzenv.inc}
+
+var
+  TZAlwaysFromEnv: boolean;
+
+procedure InitTZ2; inline;
+var
+  DT: DosCalls.TDateTime;
+begin
+  DosGetDateTime (DT);
+  TZAlwaysFromEnv := DT.TimeZone = -1;
+end;
+
+
 procedure GetLocalTime (var SystemTime: TSystemTime);
 var
   DT: DosCalls.TDateTime;
@@ -559,13 +575,76 @@ begin
     Year:=DT.Year;
     Month:=DT.Month;
     Day:=DT.Day;
+    DayOfWeek:=DT.WeekDay;
     Hour:=DT.Hour;
     Minute:=DT.Minute;
     Second:=DT.Second;
-    MilliSecond:=DT.Sec100;
+    MilliSecond:=DT.Sec100 * 10;
   end;
 end;
 
+
+function GetUniversalTime (var SystemTime: TSystemTime): boolean;
+var
+  DT: DosCalls.TDateTime;
+  Offset: longint;
+begin
+  if TZAlwaysFromEnv then
+   begin
+    GetLocalTime (SystemTime);
+    Offset := GetLocalTimeOffset;
+   end
+  else
+   begin
+    DosGetDateTime (DT);
+    with SystemTime do
+     begin
+      Year := DT.Year;
+      Month := DT.Month;
+      Day := DT.Day;
+      DayOfWeek := DT.WeekDay;
+      Hour := DT.Hour;
+      Minute := DT.Minute;
+      Second := DT.Second;
+      MilliSecond := DT.Sec100 * 10;
+     end;
+    if DT.TimeZone = -1 then
+     Offset := GetLocalTimeOffset
+    else
+     Offset := DT.TimeZone;
+   end;
+  UpdateTimeWithOffset (SystemTime, Offset);
+  GetUniversalTime := true;
+end;
+
+
+function GetLocalTimeOffset: integer;
+var
+  DT: DosCalls.TDateTime;
+begin
+  if TZAlwaysFromEnv then
+   begin
+    if InDST then
+     GetLocalTimeOffset := DSTOffsetMin
+    else
+     GetLocalTimeOffset := TZOffsetMin;
+   end
+  else
+   begin
+    DosGetDateTime (DT);
+    if DT.TimeZone <> -1 then
+     GetLocalTimeOffset := DT.TimeZone
+    else
+     begin
+      if InDST then
+       GetLocalTimeOffset := DSTOffsetMin
+      else
+       GetLocalTimeOffset := TZOffsetMin;
+     end;
+   end;
+end;
+
+
 {****************************************************************************
                               Misc Functions
 ****************************************************************************}
@@ -997,6 +1076,8 @@ Initialization
   OnBeep:=@SysBeep;
   LastOSError := 0;
   OrigOSErrorWatch := TOSErrorWatch (SetOSErrorTracking (@TrackLastOSError));
+  InitTZ;
+  InitTZ2;
 Finalization
   FreeTerminateProcs;
   DoneExceptions;

rtl/sinclairql/qdos.inc

@@ -17,10 +17,21 @@
 
 const
   _MT_INF   = $00;
+  _MT_FRJOB = $05;
   _MT_DMODE = $10;
   _MT_ALCHP = $18;
   _MT_RECHP = $19;
 
+procedure mt_frjob(jobID: Tjobid; exitCode: longint); assembler; nostackframe; public name '_mt_frjob';
+asm
+  movem.l d2-d3,-(sp)
+  move.l  exitCode,d3
+  move.l  jobID,d1
+  moveq   #_MT_FRJOB,d0
+  trap    #1
+  movem.l (sp)+,d2-d3
+end;
+
 function mt_inf(sys_vars: ppchar; ver_ascii: plongint): Tjobid; assembler; nostackframe; public name '_mt_inf';
 asm
   move.l  d2,-(sp)
@@ -28,10 +39,16 @@ asm
   move.l  ver_ascii,-(sp)
   moveq.l #_MT_INF,d0
   trap #1
-  move.l  (sp)+,a1
+  move.l  (sp)+,d0
+  beq.s   @skip_vars
+  move.l  d0,a1
   move.l  d2,(a1)   { ver_ascii }
-  move.l  (sp)+,a1
+@skip_vars:
+  move.l  (sp)+,d0
+  beq.s   @skip_ver
+  move.l  d0,a1
   move.l  a0,(a1)   { sys_vars }
+@skip_ver:
   move.l  (sp)+,d2
   move.l  d1,d0     { jobid }
 end;
@@ -44,7 +61,7 @@ asm
   moveq.l #_MT_DMODE,d0
   trap #1
   move.w d1,(a0)
-  move.w d2,(a1) 
+  move.w d2,(a1)
   movem.l (sp)+,d2/a3-a4
 end;
 
@@ -90,7 +107,8 @@ asm
   move.l mode,d3
   moveq.l #_IO_OPEN,d0
   trap #2
-  bne @quit
+  tst.l d0
+  bne.s @quit
   move.l a0,d0
 @quit:
   movem.l (sp)+,d2-d3
@@ -120,10 +138,67 @@ end;
 
 
 const
+  _IO_FBYTE = $01;
+  _IO_FLINE = $02;
+  _IO_FSTRG = $03;
   _IO_SBYTE = $05;
   _IO_SSTRG = $07;
   _SD_WDEF = $0D;
   _SD_CLEAR = $20;
+  _FS_POSAB = $42;
+  _FS_POSRE = $43;
+  _FS_HEADR = $47;
+  _FS_TRUNCATE = $4B;
+
+function io_fbyte(chan: Tchanid; timeout: Ttimeout): longint; assembler; nostackframe; public name '_io_fbyte';
+asm
+  move.l d3,-(sp)
+  move.w timeout,d3
+  clr.l d1
+  move.l chan,a0
+  moveq.l #_IO_FBYTE,d0
+  trap #3
+  tst.l d0
+  bne @quit
+  move.l d1,d0
+@quit:
+  move.l (sp)+,d3
+end;
+
+function io_fetch(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word; trap_no: longint): longint; assembler;
+asm
+  movem.l d2-d3,-(sp)
+  move.w len,d2
+  move.l buf,a1
+  move.w timeout,d3
+  move.l chan,a0
+  move.l trap_no,d0
+  trap #3
+  tst.l d0
+  beq @ok
+  cmp.w	#ERR_EF,d0
+  beq @eof
+  cmp.w #ERR_NC,d0
+  bne @quit
+@eof:
+  tst.w d1
+  beq @quit
+@ok:
+  clr.l d0
+  move.w d1,d0
+@quit:
+  movem.l (sp)+,d2-d3
+end;
+
+function io_fline(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word): longint; public name '_io_fline';
+begin
+  io_fline := io_fetch(chan, timeout, buf, len, _IO_FLINE);
+end;
+
+function io_fstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word): longint; public name '_io_fstrg';
+begin
+  io_fstrg := io_fetch(chan, timeout, buf, len, _IO_FSTRG);
+end;
 
 function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; assembler; public name '_io_sbyte';
 asm
@@ -137,7 +212,7 @@ asm
   move.l (sp)+,d3
 end;
 
-function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; assembler; public name '_io_sstrg';
+function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word): longint; assembler; public name '_io_sstrg';
 asm
   movem.l d2-d3,-(sp)
   move.w len,d2
@@ -171,20 +246,75 @@ asm
   move.b border_colour,d1
   move.l chan,a0
   moveq.l #_SD_WDEF,d0
-  trap #3 
+  trap #3
   movem.l (sp)+,d2-d3
 end;
 
-function sd_clear(chan: Tchanid; timeout: Ttimeout): longint; assembler; public name '_sd_clear';
+function sd_clear(chan: Tchanid; timeout: Ttimeout): longint; assembler; nostackframe; public name '_sd_clear';
 asm
   move.l d3,-(sp)
   move.w timeout,d3
   move.l chan,a0
   moveq.l #_SD_CLEAR,d0
-  trap #3 
+  trap #3
+  move.l (sp)+,d3
+end;
+
+
+function fs_posab(chan: Tchanid; new_pos: dword):longint; assembler; nostackframe; public name '_fs_posab';
+asm
+  move.l d3,-(sp)
+  moveq #_FS_POSAB,d0
+  move.l new_pos,d1
+  moveq #-1,d3
+  move.l chan,a0
+  trap #3
+  tst.l d0
+  bne.s  @quit
+  move.l d1,d0
+@quit:
+  move.l (sp)+,d3
+end;
+
+function fs_posre(chan: Tchanid; new_pos: dword): longint; assembler; nostackframe; public name '_fs_posre';
+asm
+  move.l d3,-(sp)
+  moveq #_FS_POSRE,d0
+  move.l new_pos,d1
+  moveq #-1,d3
+  move.l chan,a0
+  trap #3
+  tst.l d0
+  bne.s  @quit
+  move.l d1,d0
+@quit:
   move.l (sp)+,d3
 end;
 
+function fs_headr(chan: Tchanid; buf: pointer; buf_size: word): longint; assembler; nostackframe; public name '_fs_headr';
+asm
+  movem.l d2-d3,-(sp)
+  moveq #_FS_HEADR,d0
+  move.l buf_size,d2
+  moveq #-1,d3
+  move.l chan,a0
+  trap #3
+  tst.l d0
+  bne.s  @quit
+  move.l d1,d0
+@quit:
+  movem.l (sp)+,d2-d3
+end;
+
+function fs_truncate(chan: Tchanid): longint; assembler; nostackframe; public name '_fs_truncate';
+asm
+  move.l d3,-(sp)
+  moveq #_FS_TRUNCATE,d0
+  moveq #-1,d3
+  move.l chan, a0
+  trap #3
+  move.l (sp)+,d3
+end;
 
 const
   _UT_CON = $c6;
@@ -196,6 +326,7 @@ asm
   move.l params,a1
   move.w _UT_CON,a2
   jsr (a2)
+  tst.l d0
   bne @quit
   move.l a0,d0
 @quit:
@@ -208,6 +339,7 @@ asm
   move.l params,a1
   move.w _UT_SCR,a2
   jsr (a2)
+  tst.l d0
   bne @quit
   move.l a0,d0
 @quit:

rtl/sinclairql/qdosfuncs.inc

@@ -15,6 +15,7 @@
 
 {$i qdosh.inc}
 
+procedure mt_frjob(jobID: Tjobid; exitCode: longint); external name '_mt_frjob';
 function mt_inf(sys_vars: ppchar; ver_ascii: plongint): Tjobid; external name '_mt_inf';
 
 procedure mt_dmode(s_mode: pword; d_type: pword); external name '_mt_dmode';
@@ -26,8 +27,16 @@ function io_open_qlstr(name_qlstr: pointer; mode: longint): Tchanid; external na
 function io_open(name: pchar; mode: longint): Tchanid; external name '_io_open';
 function io_close(chan: Tchanid): longint; external name '_io_close';
 
+function io_fbyte(chan: Tchanid; timeout: Ttimeout): longint; external name '_io_fbyte';
+function io_fline(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word): longint; external name '_io_fline';
+function io_fstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word): longint; external name '_io_fstrg';
 function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; external name '_io_sbyte';
-function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; external name '_io_sstrg';
+function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word): longint; external name '_io_sstrg';
+
+function fs_posab(chan: Tchanid; new_pos: dword): longint; external name '_fs_posab';
+function fs_posre(chan: Tchanid; new_pos: dword): longint; external name '_fs_posre';
+function fs_headr(chan: Tchanid; buf: pointer; buf_size: word): longint; external name '_fs_headr';
+function fs_truncate(chan: Tchanid): longint; external name '_fs_truncate';
 
 function sd_wdef(chan: Tchanid; timeout: Ttimeout; border_colour: byte; border_width: word; window: PQLRect): longint; external name '_sd_wdef'; 
 function sd_clear(chan: Tchanid; timeout: Ttimeout): longint; external name '_sd_clear';

rtl/sinclairql/si_prc.pp

@@ -22,29 +22,25 @@ implementation
 {$i qdosfuncs.inc}
 
 var
-  stacktop: pointer;
-  setjmpbuf: jmp_buf;
-  stklen: longint; external name '__stklen';
   binstart: byte; external name '_stext';
   binend: byte; external name '_etext';
   bssstart: byte; external name '_sbss';
   bssend: byte; external name '_ebss';
 
-{ this is const, so it will go into the .data section, not .bss }
-const
-  stackorig: pointer = nil;
-
 procedure PascalMain; external name 'PASCALMAIN';
+procedure PascalStart; forward;
 
 { this function must be the first in this unit which contains code }
 {$OPTIMIZATION OFF}
-function _FPC_proc_start: longint; cdecl; public name '_start';
-var
-  newstack: pointer;
-begin
-  _FPC_proc_start:=0;
-  asm
-    move.l d7,-(sp)
+function _FPC_proc_start: longint; cdecl; assembler; nostackframe; public name '_start';
+asm
+    bra   @start
+    dc.l  $0
+    dc.w  $4afb
+    dc.w  3
+    dc.l  $46504300   { Job name, just FPC for now }
+
+@start:
     { relocation code }
 
     { get our actual position in RAM }
@@ -80,36 +76,22 @@ begin
     bne @relocloop
 
 @noreloc:
-    move.l (sp)+,d7
+    jsr PascalStart
+end;
 
-    { save the original stack pointer }
-    move.l a7,stackorig
-  end;
+procedure _FPC_proc_halt(_ExitCode: longint); public name '_haltproc';
+begin
+  mt_frjob(-1, _ExitCode);
+end;
 
+procedure PascalStart;
+begin
   { initialize .bss }
   FillChar(bssstart,PtrUInt(@bssend)-PtrUInt(@bssstart),#0);
 
-  newstack:=mt_alchp(stklen,nil,-1);
-  if not assigned(newstack) then
-    _FPC_proc_start:=ERR_OM
-  else
-    begin
-      stacktop:=pbyte(newstack)+stklen;
-      asm
-        move.l stacktop,sp
-      end;
-      if setjmp(setjmpbuf) = 0 then
-        PascalMain;
-      asm
-        move.l stackorig,sp
-      end;
-      mt_rechp(newstack);
-   end;
-end;
+  PascalMain;
 
-procedure _FPC_proc_halt(_ExitCode: longint); public name '_haltproc';
-begin
-  longjmp(setjmpbuf,1); 
+  Halt; { this should never be reached }
 end;
 
 

rtl/sinclairql/sysfile.inc

@@ -50,37 +50,67 @@ end;
 
 
 function do_read(h: longint; addr: pointer; len: longint) : longint;
+var
+  res: longint;
 begin
-  do_read:=-1;
+  do_read := 0;
+  res := io_fline(h, -1, addr, len);
+  if res < 0 then
+    Error2InOutRes(res)
+  else
+    do_read := res;
 end;
 
 
-function do_filepos(handle: longint) : longint;
+function do_filepos(handle: longint): longint;
+var
+  res: longint;
 begin
-  do_filepos:=-1;
+  do_filepos := 0;
+  res := fs_posre(handle, 0);
+  if res < 0 then
+    Error2InOutRes(res)
+  else
+    do_filepos := res;
 end;
 
 
 procedure do_seek(handle, pos: longint);
+var
+  res: longint;
 begin
+  res := fs_posab(handle, pos);
+  if res < 0 then
+    Error2InOutRes(res);
 end;
 
 
-function do_seekend(handle: longint):longint;
+function do_seekend(handle: longint): longint;
 begin
-  do_seekend:=-1;
+  do_seek(handle, -1);
+  do_seekend := do_filepos(handle);
 end;
 
 
-function do_filesize(handle : THandle) : longint;
+function do_filesize(handle: longint): longint;
+var
+  res: longint;
+  header: array [0..$39] of byte;
 begin
-  do_filesize:=-1;
+  do_filesize := 0;
+  res := fs_headr(handle, @header, $40);
+  if res < 0 then
+    Error2InOutRes(res)
+  else
+    do_filesize := plongint(@header[0])^;
 end;
 
 
 { truncate at a given position }
 procedure do_truncate(handle, pos: longint);
 begin
+  do_seek(handle, pos);
+  fs_truncate(handle);
 end;
 
 

rtl/sinclairql/system.pp

@@ -51,7 +51,7 @@ const
     DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
 
 const
-    UnusedHandle    = $ffff;
+    UnusedHandle    = -1;
     StdInputHandle: longint = UnusedHandle;
     StdOutputHandle: longint = UnusedHandle;
     StdErrorHandle: longint = UnusedHandle;
@@ -62,8 +62,6 @@ var
     argv: PPChar;
     envp: PPChar;
 
-    QCON: longint; // QDOS console
-    QSCR: longint; // QDOS screen
     heapStart: pointer;
 
 
@@ -76,71 +74,61 @@ var
     {$endif defined(FPUSOFT)}
 
 
-  implementation
+implementation
 
-    {$if defined(FPUSOFT)}
-
-    {$define fpc_softfpu_implementation}
-    {$define softfpu_compiler_mul32to64}
-    {$define softfpu_inline}
-    {$i softfpu.pp}
-    {$undef fpc_softfpu_implementation}
-
-    { we get these functions and types from the softfpu code }
-    {$define FPC_SYSTEM_HAS_float64}
-    {$define FPC_SYSTEM_HAS_float32}
-    {$define FPC_SYSTEM_HAS_flag}
-    {$define FPC_SYSTEM_HAS_extractFloat64Frac0}
-    {$define FPC_SYSTEM_HAS_extractFloat64Frac1}
-    {$define FPC_SYSTEM_HAS_extractFloat64Exp}
-    {$define FPC_SYSTEM_HAS_extractFloat64Sign}
-    {$define FPC_SYSTEM_HAS_ExtractFloat32Frac}
-    {$define FPC_SYSTEM_HAS_extractFloat32Exp}
-    {$define FPC_SYSTEM_HAS_extractFloat32Sign}
-
-    {$endif defined(FPUSOFT)}
+  {$if defined(FPUSOFT)}
 
-    {$i system.inc}
-    {$ifdef FPC_QL_USE_TINYHEAP}
-    {$i tinyheap.inc}
-    {$endif FPC_QL_USE_TINYHEAP}
+  {$define fpc_softfpu_implementation}
+  {$define softfpu_compiler_mul32to64}
+  {$define softfpu_inline}
+  {$i softfpu.pp}
+  {$undef fpc_softfpu_implementation}
 
+  { we get these functions and types from the softfpu code }
+  {$define FPC_SYSTEM_HAS_float64}
+  {$define FPC_SYSTEM_HAS_float32}
+  {$define FPC_SYSTEM_HAS_flag}
+  {$define FPC_SYSTEM_HAS_extractFloat64Frac0}
+  {$define FPC_SYSTEM_HAS_extractFloat64Frac1}
+  {$define FPC_SYSTEM_HAS_extractFloat64Exp}
+  {$define FPC_SYSTEM_HAS_extractFloat64Sign}
+  {$define FPC_SYSTEM_HAS_ExtractFloat32Frac}
+  {$define FPC_SYSTEM_HAS_extractFloat32Exp}
+  {$define FPC_SYSTEM_HAS_extractFloat32Sign}
 
-  function GetProcessID:SizeUInt;
-  begin
-    GetProcessID := 1;
-  end;
+  {$endif defined(FPUSOFT)}
 
+  {$i system.inc}
+  {$ifdef FPC_QL_USE_TINYHEAP}
+  {$i tinyheap.inc}
+  {$endif FPC_QL_USE_TINYHEAP}
 
-  procedure SysInitParamsAndEnv;
-  begin
-  end;
 
+function GetProcessID:SizeUInt;
+begin
+  GetProcessID := mt_inf(nil, nil);
+end;
 
-  procedure randomize;
-  begin
-    {$WARNING: randseed is uninitialized}
-    randseed:=0;
-  end;
+procedure SysInitParamsAndEnv;
+begin
+end;
 
-procedure PrintStr(ch: longint; const s: shortstring);
+procedure randomize;
 begin
-  io_sstrg(ch,-1,@s[1],ord(s[0]));
+  {$WARNING: randseed is uninitialized}
+  randseed:=0;
 end;
 
-procedure PrintStr2(ch: longint; const s: shortstring);
-var
-  i: smallint;
+procedure PrintStr(ch: longint; const s: shortstring);
 begin
-  for i:=1 to ord(s[0]) do
-    io_sbyte(ch,-1,s[i]);
+  io_sstrg(ch,-1,@s[1],ord(s[0]));
 end;
 
 procedure DebugStr(const s: shortstring); public name '_dbgstr';
 var
   i: longint;
 begin
-  PrintStr($00010001,s);
+  PrintStr(stdOutputHandle,s);
   for i:=0 to 10000 do begin end;
 end;
 
@@ -165,17 +153,14 @@ begin
   stdInputHandle:=io_open('con_',Q_OPEN);
   stdOutputHandle:=stdInputHandle;
   stdErrorHandle:=stdInputHandle;
-  QCON:=stdInputHandle;
 
   r.q_width:=512;
   r.q_height:=256;
   r.q_x:=0;
   r.q_y:=0;
 
-  sd_wdef(stdInputHandle,-1,0,16,@r);
+  sd_wdef(stdInputHandle,-1,2,1,@r);
   sd_clear(stdInputHandle,-1);
-
-//  QSCR:=io_open('scr_',Q_OPEN);
 end;
 
 {*****************************************************************************
@@ -185,13 +170,15 @@ end;
 procedure haltproc(e:longint); external name '_haltproc';
 
 procedure system_exit;
+const
+  anyKey: string = 'Press any key to exit';
 begin
-//  io_close(QCON);
-//  io_close(QSCR);
+  io_sstrg(stdOutputHandle, -1, @anyKey[1], ord(anyKey[0]));
+  io_fbyte(stdInputHandle, -1);
+
   stdInputHandle:=UnusedHandle;
   stdOutputHandle:=UnusedHandle;
   stdErrorHandle:=UnusedHandle;
-
   haltproc(exitcode);
 end;
 

rtl/watcom/sysutils.pp

@@ -49,6 +49,7 @@ implementation
 
 {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
 {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
+{$DEFINE HAS_LOCALTIMEZONEOFFSET}
 
 { Include platform independent implementation part }
 {$i sysutils.inc}
@@ -635,6 +636,8 @@ end;
                               Time Functions
 ****************************************************************************}
 
+{$I tzenv.inc}
+
 Procedure GetLocalTime(var SystemTime: TSystemTime);
 var
   Regs: Registers;
@@ -650,6 +653,7 @@ begin
   SystemTime.Year := Regs.Cx;
   SystemTime.Month := Regs.Dh;
   SystemTime.Day := Regs.Dl;
+  SystemTime.DayOfWeek := Regs.Al;
 end ;
 
 
@@ -657,6 +661,17 @@ end ;
                               Misc Functions
 ****************************************************************************}
 
+const
+  BeepChars: array [1..2] of char = #7'$';
+
+procedure sysBeep;
+var
+  Regs: Registers;
+begin
+  Regs.dx := Ofs (BeepChars);
+  Regs.ah := 9;
+  MsDos (Regs);
+end;
 
 {****************************************************************************
                               Locale Functions
@@ -901,6 +916,8 @@ Initialization
   InitExceptions;       { Initialize exceptions. OS independent }
   InitInternational;    { Initialize internationalization settings }
   InitDelay;
+  OnBeep:=@SysBeep;
+  InitTZ;
 Finalization
   FreeTerminateProcs;
   DoneExceptions;

rtl/x86_64/math.inc

@@ -104,19 +104,31 @@ const
     {$ifndef FPC_SYSTEM_HAS_ABS}
     {$define FPC_SYSTEM_HAS_ABS}
     function fpc_abs_real(d : ValReal) : ValReal;compilerproc;
+{$ifndef cpullvm}
     begin
       { Function is handled internal in the compiler }
       runerror(207);
       result:=0;
+{$else not cpullvm}
+    assembler;
+    asm
+      fldt d
+      fabs
+{$endif not cpullvm}
     end;
     {$endif FPC_SYSTEM_HAS_ABS}
     {$ifndef FPC_SYSTEM_HAS_SQR}
     {$define FPC_SYSTEM_HAS_SQR}
     function fpc_sqr_real(d : ValReal) : ValReal;compilerproc;
+{$ifndef cpullvm}
     begin
       { Function is handled internal in the compiler }
       runerror(207);
       result:=0;
+{$else not cpullvm}
+    begin
+      fpc_sqr_real:=d*d;
+{$endif not cpullvm}
     end;
     {$endif FPC_SYSTEM_HAS_SQR}
     {$ifndef FPC_SYSTEM_HAS_SQRT}

tests/test/tfma1.inc

@@ -241,6 +241,7 @@ procedure testsingle;
       halt(1);
   end;
 
+{$ifndef NODOUBLE}
 
 procedure testdouble;
   var
@@ -480,3 +481,5 @@ procedure testdouble;
     if l0<>-10.0 then
       halt(1);
   end;
+
+{$endif NODOUBLE}

tests/test/tfma1xtensa.pp

@@ -0,0 +1,30 @@
+{ %CPU=xtensa }
+
+{$define NODOUBLE}
+
+{$i tfma1.inc}
+
+begin
+  {
+  d1:=2;
+  d2:=3;
+  d3:=4;
+  d0:=FMADouble(d1,d2,d3);
+  writeln(d0);
+  if d0<>10.0 then
+    halt(1);
+  }
+
+  s1:=2;
+  s2:=3;
+  s3:=4;
+  s0:=FMASingle(s1,s2,s3);
+  writeln(s0);
+  if s0<>10.0 then
+    halt(1);
+
+  testsingle;
+  // testdouble;
+
+  writeln('ok');
+end.

utils/fpdoc/dw_html.pp

@@ -2412,17 +2412,21 @@ procedure THTMLWriter.CreateClassHierarchyPage(AList : TStringList; AddUnit : Bo
     PushOutputNode(h);
   end;
 
-  Procedure AppendClass(E : TDomElement);
+  Procedure AppendClass(E : TPasElementNode);
 
   Var
     N : TDomNode;
-    P,PM : TPasElement;
+    P,PM,M : TPasElement;
     EN : String;
     LL : TstringList;
     I,J : Integer;
 
   begin
-    EN:=Package.Name+'.'+UTF8Encode(E['unit'])+'.'+UTF8Encode(E.NodeName);
+    M:=E.Element.GetModule;
+    if (M<>Nil) then
+      EN:=Package.Name+'.'+UTF8Encode(M.Name)+'.'+UTF8Encode(E.Element.Name)
+    else
+      EN:=UTF8Encode(E.Element.Name);
     J:=AList.IndexOf(EN);
     If J<>-1 then
       P:=AList.Objects[J] as TPasElement
@@ -2442,30 +2446,17 @@ procedure THTMLWriter.CreateClassHierarchyPage(AList : TStringList; AddUnit : Bo
           end
         end
       else
-        AppendText(CurOutputNode,E.Nodename);
-      LL:=TStringList.Create;
-      try
-        N:=E.FirstChild;
-        While (N<>Nil) do
-          begin
-          if (N.NodeType=ELEMENT_NODE) then
-            LL.AddObject(UTF8Encode(N.NodeName),N);
-          N:=N.NextSibling;
-          end;
-        if (LL.Count>0) then
-          begin
-          LL.Sorted:=true;
-          PushClassList;
-          try
-            For I:=0 to LL.Count-1 do
-              AppendClass(LL.Objects[i] as TDomElement);
-          finally
-            PopOutputNode;
-          end;
-          end;
-      finally
-        LL.Free;
-      end;
+        AppendText(CurOutputNode,E.Element.Name);
+      if E.ChildCount>0 then
+        begin
+        PushClassList;
+        try
+          For I:=0 to E.ChildCount-1 do
+            AppendClass(E.Children[i] as TPasElementNode);
+        finally
+          PopOutputNode;
+        end;
+        end;
     Finally
       PopOutputNode;
     end;
@@ -2473,7 +2464,8 @@ procedure THTMLWriter.CreateClassHierarchyPage(AList : TStringList; AddUnit : Bo
 
 Var
   B : TClassTreeBuilder;
-  E : TDomElement;
+  E : TPasElementNode;
+
 begin
   PushOutputNode(BodyElement);
   try
@@ -2483,7 +2475,7 @@ begin
       // Classes
       // WriteXMLFile(B.ClassTree,'tree.xml');
       // Dummy TObject
-      E:=B.ClassTree.DocumentElement;
+      E:=B.RootNode;
       PushClassList;
       try
         AppendClass(E);

utils/fpdoc/fpclasschart.pp

@@ -509,7 +509,47 @@ begin
   else
     Writeln(StdErr,Format(SSkipMerge,[S.NodeName,D.NodeName]));
 end;
-  
+
+Function MergeTrees (Dest : TXMLDocument; aRootNode : TPasElementNode) : Integer;
+
+Var
+  aSrc : TXMLDocument;
+
+  Procedure AppendChildClasses(aParent : TDomElement; aNode : TPasElementNode);
+
+  Var
+    El : TDomElement;
+    aChild : TPasElementNode;
+    I : Integer;
+    M : TPasModule;
+
+  begin
+    If (ANode=Nil) or (aNode.ChildCount=0)  then exit;
+    for I:=0 to aNode.ChildCount-1 do
+      begin
+      aChild:=aNode.Children[I];
+      El:=aSrc.CreateElement(UTF8Decode(aChild.Element.Name));
+      M:=aChild.Element.GetModule;
+      If M<>Nil then
+        EL['unit']:=UTF8Decode(M.Name);
+      aParent.AppendChild(El);
+      AppendChildClasses(El,aChild);
+      end;
+  end;
+
+begin
+  aSrc:=TXMLDocument.Create();
+  try
+    aSrc.AppendChild(aSrc.CreateElement('TObject'));
+    AppendChildClasses(aSrc.DocumentElement,aRootNode);
+    MergeTrees(Dest,aSrc);
+  finally
+    aSrc.Free;
+  end;
+end;
+
+
+
 Function AnalyseFiles(Const AOutputName : String; InputFiles,MergeFiles : TStrings; AObjectKind : TPasObjKind) : String;
 
 
@@ -542,7 +582,7 @@ begin
       Try
         ParseSource(Engine,InputFiles[I],OSTarget,CPUTarget);
         Engine.Ftree.BuildTree(Engine.FObjects);
-        ACount:=ACount+MergeTrees(XML,Engine.FTree.ClassTree);
+        ACount:=ACount+MergeTrees(XML,Engine.FTree.RootNode);
       Finally
         FreeAndNil(Engine);
       end;

utils/fpdoc/fpdocclasstree.pp

@@ -5,188 +5,184 @@ unit fpdocclasstree;
 interface
 
 uses
-  Classes, SysUtils, DOM, pastree;
+  Classes, SysUtils, DOM, pastree, contnrs;
 
 Type
+
+  { TPasElementNode }
+
+  TPasElementNode = Class
+  Private
+    FElement : TPasElement;
+    FChildren : TFPObjectList;
+    function GetChild(aIndex : Integer): TPasElementNode;
+    function GetChildCount: Integer;
+  Public
+    Constructor Create (aElement : TPaselement);
+    Destructor Destroy; override;
+    Procedure AddChild(C : TPasElementNode);
+    Procedure SortChildren;
+    Property Element : TPasElement Read FElement;
+    Property Children [aIndex : Integer] : TPasElementNode Read GetChild;
+    Property ChildCount : Integer Read GetChildCount;
+  end;
+
+  { TClassTreeBuilder }
+
   TClassTreeBuilder = Class
   Private
-    FClassTree : TXMLDocument;
-    FTreeStart : TDomElement;
+    // Full name -> TDomElement;
+    FElementList : TFPObjectHashTable;
     FObjectKind : TPasObjKind;
     FPackage: TPasPackage;
     FParentObject : TPasClassType;
+    FRootNode : TPasElementNode;
+    FRootObjectName : string;
   Protected
-    function LookForElement(PE: TDomElement; AElement: TPasElement; NoPath : Boolean): TDomNode;
-    function NodeMatch(N: TDomNode; AElement: TPasElement; NoPath : Boolean): Boolean;
-    Function AddToClassTree(AElement : TPasElement; Var ACount : Integer) : TDomElement;
+    function AddToList(aElement: TPasClassType): TPasElementNode;
   Public
     Constructor Create(APackage : TPasPackage; AObjectKind : TPasObjKind = okClass);
     Destructor Destroy; override;
     Function BuildTree(AObjects : TStringList) : Integer;
-    Property ClassTree : TXMLDocument Read FClassTree;
+    Property RootNode : TPasElementNode Read FRootNode;
   end;
 
 implementation
 
+{ TPasElementNode }
+
+function SortOnElementName(Item1, Item2: Pointer): Integer;
+begin
+  Result:=CompareText(TPasElementNode(Item1).Element.Name,TPasElementNode(Item2).Element.Name);
+end;
+
+function TPasElementNode.GetChild(aIndex : Integer): TPasElementNode;
+begin
+  if Assigned(FChildren) then
+    Result:=TPasElementNode(FChildren[aIndex])
+  else
+    Raise EListError.Create('Index out of range');
+end;
+
+function TPasElementNode.GetChildCount: Integer;
+begin
+  if Assigned(FChildren) then
+    Result:=FChildren.Count
+  else
+    Result:=0
+end;
+
+constructor TPasElementNode.Create(aElement: TPaselement);
+begin
+  FElement:=aElement;
+end;
+
+destructor TPasElementNode.Destroy;
+begin
+  FreeAndNil(FChildren);
+  inherited Destroy;
+end;
+
+procedure TPasElementNode.AddChild(C: TPasElementNode);
+begin
+  if FChildren=Nil then
+    FChildren:=TFPObjectList.Create(True);
+  FChildren.Add(C);
+end;
+
+procedure TPasElementNode.SortChildren;
+begin
+  if Assigned(FChildren) then
+    FChildren.Sort(@SortOnElementName);
+end;
+
 constructor TClassTreeBuilder.Create(APackage : TPasPackage;
   AObjectKind: TPasObjKind);
 
 begin
-  FCLassTree:=TXMLDocument.Create;
   FPackage:=APAckage;
   FObjectKind:=AObjectKind;
   Case FObjectkind of
-    okObject    : FParentObject:=TPasClassType.Create('System.TObject',FPackage);
-    okClass     : FParentObject:=TPasClassType.Create('System.TObject',FPackage);
-    okInterface : FParentObject:=TPasClassType.Create('System.IInterface',FPackage);
+    okInterface : FRootObjectName:='#rtl.System.IInterface';
+    okObject,
+    okClass    : FRootObjectName:='#rtl.System.TObject';
+  else
+    FRootObjectName:='#rtl.System.TObject';
   end;
+  FParentObject:=TPasClassType.Create(FRootObjectName,FPackage);
   FParentObject.ObjKind:=FObjectKind;
-  FTreeStart:=FClassTree.CreateElement('TObject');
-  FTreeStart['unit']:='System';
-  ClassTree.AppendChild(FTreeStart);
+  FRootNode:=TPasElementNode.Create(FParentObject);
+  FElementList:=TFPObjectHashTable.Create(False);
+  FElementList.Add(FRootObjectName,FRootNode);
 end;
 
 destructor TClassTreeBuilder.Destroy;
 begin
   FreeAndNil(FParentObject);
-  FreeAndNil(FClassTree);
+  FreeAndNil(FRootNode);
+  FreeAndNil(FElementList);
   Inherited;
 end;
 
-Function TClassTreeBuilder.BuildTree(AObjects : TStringList) : Integer;
+Function TClassTreeBuilder.AddToList(aElement : TPasClassType) : TPasElementNode;
 
 Var
-  I : Integer;
-  PC : TPasClassType;
+  aParentNode : TPasElementNode;
+  aName : String;
 
 begin
-  Result:=0;
-  AObjects.Sorted:=True;
-  For I:=0 to AObjects.Count-1 do
-    // Advanced records
-    if AObjects.Objects[i] is TPasClassType then
-      begin
-      PC:=AObjects.Objects[i] as TPasClassType;
-      If (PC.ObjKind=FObjectKind) and Not PC.IsForward then
-        AddToClassTree(PC,Result);
-      end;
-end;
-
-Function TClassTreeBuilder.NodeMatch(N : TDomNode; AElement : TPasElement; NoPath : Boolean) : Boolean;
-
-Var
-  PN,S,EN : String;
-
-begin
-  EN:=AELement.Name;
-  Result:=(N.NodeType=ELEMENT_NODE);
-  if Result then
+  if aElement=Nil then
+    aName:=FRootObjectName
+  else
+    begin
+    aName:=aElement.PathName;
+    end;
+  Result:=TPasElementNode(FElementList.Items[aName]);
+  if (Result=Nil) then
     begin
-    S:=UTF8Encode(N.NodeName);
-    if NoPath then
-      Begin
-      Result:=CompareText(S,EN)=0;
-      end
+    if aElement.AncestorType is TPasClassType then
+      aParentNode:=AddToList(aElement.AncestorType as TPasClassType)
     else
-      begin
-      IF Assigned(Aelement.GetModule) then
-        PN:=Aelement.GetModule.PackageName
-      else
-        PN:=FPackage.Name;
-      S:=PN+'.'+UTF8Encode(TDomElement(N)['unit'])+'.'+S;
-      Result:=(CompareText(S,AElement.PathName)=0);
-      end;
-   end;
+      aParentNode:=FRootNode;
+    Result:=TPasElementNode.Create(aElement);
+    aParentNode.AddChild(Result);
+    FElementList.Add(aName,Result);
+    end;
 end;
 
-Function TClassTreeBuilder.LookForElement(PE : TDomElement; AElement : TPasElement; NoPath : boolean) : TDomNode;
 
-Var
-  N : TDomNode;
+Function TClassTreeBuilder.BuildTree(AObjects : TStringList) : Integer;
 
-begin
-//  Writeln('Enter TClassTreeBuilderLookForElement');
-  Result:=PE;
-  While (Result<>Nil) and Not NodeMatch(Result,AElement,NoPath) do
-    Result:=Result.NextSibling;
-  If (Result=Nil) then
-    if  Assigned(PE) then
-      begin
-      N:=PE.FirstChild;
-      While (Result=Nil) and (N<>Nil) do
-        begin
-        if (N.NodeType=ELEMENT_NODE) then
-          begin
-          Result:=LookForElement(N as TDomElement,AElement,NoPath);
-          end;
-        N:=N.NextSibling;
-        end;
-      end;
-//  Writeln('Exit TClassTreeBuilderLookForElement');
-end;
+(*
+Procedure DumpNode(Prefix : String; N : TPasElementNode);
+
+  Var
+    I : Integer;
+
+  begin
+    Writeln(Prefix,N.FElement.Name);
+    if Assigned(N.FChildren) then
+       For I:=0 to N.FChildren.Count-1 do
+         DumpNode(Prefix+'  ',TPasElementNode(N.FChildren[i]));
+  end;
+*)
 
-Function TClassTreeBuilder.AddToClassTree(AElement : TPasElement; Var ACount : Integer) : TDomElement;
-// there are several codepaths that use uninitialized variables. (N,PE)
-// I initialized them to nil to at least make failures deterministic.
 Var
+  I : Integer;
   PC : TPasClassType;
-  PE : TDomElement;
-  M : TPasModule;
-  N : TDomNode;
 
 begin
-
-//  Writeln('Enter TClassTreeBuilder.AddToClassTree');
-  //if Assigned(AElement) then
-    //Writeln('Addtoclasstree : ',aElement.Name);
-  Result:=Nil; M:=Nil; N:=Nil;PE:=NIL;PC:=Nil;
-  If (AElement=Nil) then
-    begin
-    Result:=FTreeStart;
-    Exit;
-    end
-  else If (AElement is TPasUnresolvedTypeRef) then
-    begin
-    N:=LookForElement(FTreeStart,AElement,True);
-    If (N=Nil) then
-      PE:=FTreeStart;
-    end
-  else If (AElement is TPasClassType) then
-    begin
-    if (AElement=FParentObject) then
-      Result:=FTreeStart
-    else
-      begin
-      PC:=AElement as TPasClassType;
-      PE:=AddToClassTree(PC.AncestorType,ACount);
-      if PE=Nil then
-        PE:=FTreeStart;
-      N:=LookForElement(PE,PC,False);
-      end
-    end;
-  If (N<>Nil) then
-    begin
-    Result:=N as TDomElement
-    end
-  else if AElement.Name<>'' then
-    begin // N=NIL, PE might be nil.
-    Inc(ACount);
-    Result:=FClassTree.CreateElement(UTF8Decode(AElement.Name));
-    If Not (AElement is TPasUnresolvedTypeRef) then
-      begin
-      M:=AElement.GetModule;
-      if Assigned(M) then
-        Result['unit']:=UTF8Decode(M.Name);
-      end;
-    if PE=Nil then
+  Result:=0;
+  For I:=0 to AObjects.Count-1 do
+    // Advanced records
+    if AObjects.Objects[i] is TPasClassType then
       begin
-      PE:=FTreeStart
+      PC:=AObjects.Objects[i] as TPasClassType;
+      AddToList(PC);
       end;
-    // if not assigned, probably needs to be assigned to something else.
-    if assigned(PE) then
-      PE.AppendChild(Result);
-    end;
 end;
 
+
+
 end.