{$ifdef LINUX}
{$include ../defines.pas}
{$else}
{$include ..\defines.pas}
{$endif}
unit reg_round;

interface

uses fpu_types;

// Flags for FPU_bits_lost
const
  LOST_DOWN = 1;

const
  LOST_UP = 2;

// Flags for FPU_denormal
const
  DENORMAL = 1;

const
  UNMASKED_UNDERFLOW = 2;

  {$include fpu_const.pas}
function FPU_round (x: PFPU_REG; extent: u32; dummy: intg; control_w: u16;
  sign: u8): intg;
function round_up_64 (x: PFPU_REG; extent: u32): intg;
function truncate_64 (x: PFPU_REG; extent: u32): intg;
function round_up_53 (x: PFPU_REG; extent: u32): intg;

implementation

uses errors;

function round_up_64 (x: PFPU_REG; extent: u32): intg;
  begin
    Inc(x^.sigl);
    if (x^.sigl = 0) then
      begin
      Inc(x^.sigl);
      if (x^.sigh = 0) then
        begin
        x^.sigh := $8000;
        Inc(x^.exp);
        end;
      end;
    Result := LOST_UP;
  end;

function truncate_64 (x: PFPU_REG; extent: u32): intg;
  begin
    Result := LOST_DOWN;
  end;

function round_up_53 (x: PFPU_REG; extent: u32): intg;
  begin
    x^.sigl := x^.sigl and $fffff800;
    Inc(x^.sigl, $800);
    if (x^.sigl = 0) then
      begin
      Inc(x^.sigh);
      if (x^.sigh = 0) then
        begin
        x^.sigh := $8000;
        Inc(x^.exp);
        end;
      end;
    Result := LOST_UP;
  end;

function truncate_53 (x: PFPU_REG; extent: u32): intg;
  begin
    x^.sigl := x^.sigl and $fffff800;
    Result  := LOST_DOWN;
  end;

function round_up_24 (x: PFPU_REG; extent: u32): intg;
  begin
    x^.sigl := 0;
    x^.sigh := x^.sigh and $ffffff00;
    Inc(x^.sigh, $100);
    if (x^.sigh = 0) then
      begin
      x^.sigh := $8000;
      Inc(x^.exp);
      end;
    Result := LOST_UP;
  end;

function truncate_24 (x: PFPU_REG; extent: u32): intg;
  begin
    x^.sigl := 0;
    x^.sigh := x^.sigh and $ffffff00;
    Result  := LOST_DOWN;
  end;

function FPU_round (x: PFPU_REG; extent: u32; dummy: intg; control_w: u16;
  sign: u8): intg;
  var
    work:  u64;
    leading: u32;
    expon: s16;
    FPU_bits_lost, FPU_denormal, shift, tag: intg;
  begin
    expon := x^.exp;
    FPU_bits_lost := 0;
    if (expon <= EXP_UNDER) then
      begin
      (* A denormal or zero *)
      if (control_w and CW_Underflow) <> 0 then
        begin
        (* Underflow is masked. *)
        FPU_denormal := DENORMAL;
        shift := EXP_UNDER + 1 - expon;
        if (shift >= 64) then
          begin
          if (shift = 64) then
            begin
            Inc(x^.exp, 64);
            if (extent or x^.sigl) <> 0 then
              extent := x^.sigh or 1
            else
              extent := x^.sigh;
            end
          else
            begin
            x^.exp := EXP_UNDER + 1;
            extent := 1;
            end;
          pu64(x)^ := 0;
          end
        else
          begin
          Inc(x^.exp, shift);
          if (shift >= 32) then
            begin
            Dec(shift, 32);
            if (shift) <> 0 then
              begin
              extent := extent or x^.sigl;
              work := x^.sigh shr shift;
              if (extent) <> 0 then
                extent := work or 1
              else
                extent := work;
              x^.sigh := x^.sigh shr shift;
              x^.sigl := x^.sigh;
              end
            else
              begin
              if (extent) <> 0 then
                extent := x^.sigl or 1
              else
                extent := x^.sigl;
              x^.sigl := x^.sigh;
              end;
            x^.sigh := 0;
            end
          else
            begin
            (* Shift by 1 to 32 places. *)
            work := x^.sigl;
            work := work shl 32;
            work := work or extent;
            work := work shr shift;
            if (extent) <> 0 then
              extent := 1;
            extent := extent or work;
            pu64(x^.sigh)^ := pu64(x^.sigh)^ shr shift;
            end;
          end;
        end
      else
        begin
        (* Unmasked underflow. *)
        FPU_denormal := UNMASKED_UNDERFLOW;
        end;
      end
    else
      FPU_denormal := 0;

    case (control_w and CW_PC) of
      01:
        begin
        {$ifndef PECULIAR_486}
      (* With the precision control bits set to 01 '(reserved)', a real 80486
   behaves as if the precision control bits were set to 11 '64 bits' *)
        {$ifdef PARANOID}
        Exception(EX_INTERNAL|$236);
        return - 1;
        {$endif}
        {$endif}
        end;
      (* Fall through to the 64 bit case. *)
      PR_64_BITS:
        begin
        if (extent) <> 0 then
          begin
          case (control_w and CW_RC) of
            RC_RND:
              begin(* Nearest or even *)
              (* See if there is exactly half a ulp. *)
              if (extent = $80000000) then
                begin
                (* Round to even. *)
                if (x^.sigl and $1) <> 0 then
                  (* Odd *)
                  FPU_bits_lost := round_up_64(x, extent)
                else
                  (* Even *)
                  FPU_bits_lost := truncate_64(x, extent);
                end
              else
                if (extent > $80000000) then
                  begin
                  (* Greater than half *)
                  FPU_bits_lost := round_up_64(x, extent);
                  end
                else
                  begin
                  (* Less than half *)
                  FPU_bits_lost := truncate_64(x, extent);
                  end;
              end;

            RC_CHOP:    (* Truncate *)
              begin
              FPU_bits_lost := truncate_64(x, extent);
              end;

            RC_UP:    (* Towards +infinity *)
              begin
              if (sign = SIGN_POS) then
                begin
                FPU_bits_lost := round_up_64(x, extent);
                end
              else
                begin
                FPU_bits_lost := truncate_64(x, extent);
                end;
              end;

            RC_DOWN:    (* Towards -infinity *)
              begin
              if (sign <> SIGN_POS) then
                begin
                FPU_bits_lost := round_up_64(x, extent);
                end
              else
                begin
                FPU_bits_lost := truncate_64(x, extent);
                end;
              end;

            else
              begin
              //EXCEPTION(EX_INTERNAL|$231); MANCA!!!
              Result := -1;
              exit;
              end;
            end;
          end;
        end;

      PR_53_BITS:
        begin
        leading := x^.sigl and $7ff;
        if ((extent <> 0) or (leading <> 0)) then
          begin
          case (control_w and CW_RC) of
            RC_RND:    (* Nearest or even *)
              begin
              (* See if there is exactly half a ulp. *)
              if (leading = $400) then
                begin
                if (extent = 0) then
                  begin
                  (* Round to even. *)
                  if (x^.sigl and $800) <> 0 then
                    FPU_bits_lost := round_up_53(x, extent)
                  else
                    FPU_bits_lost := truncate_53(x, extent);
                  end
                else
                  begin
                  (* Greater than half *)
                  FPU_bits_lost := round_up_53(x, extent);
                  end;
                end
              else
                if (leading > $400) then
                  begin
                  (* Greater than half *)
                  FPU_bits_lost := round_up_53(x, extent);
                  end
                else
                  begin
                  (* Less than half *)
                  FPU_bits_lost := truncate_53(x, extent);
                  end;
              end;
            RC_CHOP:    (* Truncate *)
              begin
              FPU_bits_lost := truncate_53(x, extent);
              end;

            RC_UP:    (* Towards +infinity *)
              begin
              if (sign = SIGN_POS) then
                begin
                FPU_bits_lost := round_up_53(x, extent);
                end
              else
                begin
                FPU_bits_lost := truncate_53(x, extent);
                end;
              end;

            RC_DOWN:    (* Towards -infinity *)
              begin
              if (sign <> SIGN_POS) then
                begin
                FPU_bits_lost := round_up_53(x, extent);
                end
              else
                begin
                FPU_bits_lost := truncate_53(x, extent);
                end;
              end;

            else
              begin
              //EXCEPTION(EX_INTERNAL|$231); manca
              Result := -1;
              Exit;
              end;
            end;
          end;
        end;

      PR_24_BITS:
        begin
        leading := x^.sigh and $ff;
        if (leading <> 0) or (x^.sigl <> 0) or (extent <> 0) then
          begin
          case (control_w and CW_RC) of
            RC_RND:    (* Nearest or even *)
              begin
              (* See if there is exactly half a ulp. *)
              if (leading = $80) then
                begin
                if ((x^.sigl = 0) and (extent = 0)) then
                  begin
                  (* Round to even. *)
                  if (x^.sigh and $100) <> 0 then
                    (* Odd *)
                    FPU_bits_lost := round_up_24(x, extent)
                  else
                    (* Even *)
                    FPU_bits_lost := truncate_24(x, extent);
                  end
                else
                  begin
                  (* Greater than half *)
                  FPU_bits_lost := round_up_24(x, extent);
                  end;
                end
              else
                if (leading > $80) then
                  begin
                  (* Greater than half *)
                  FPU_bits_lost := round_up_24(x, extent);
                  end
                else
                  begin
                  (* Less than half *)
                  FPU_bits_lost := truncate_24(x, extent);
                  end;
              end;

            RC_CHOP:    (* Truncate *)
              begin
              FPU_bits_lost := truncate_24(x, extent);
              end;

            RC_UP:    (* Towards +infinity *)
              begin
              if (sign = SIGN_POS) then
                begin
                FPU_bits_lost := round_up_24(x, extent);
                end
              else
                begin
                FPU_bits_lost := truncate_24(x, extent);
                end;
              end;

            RC_DOWN:    (* Towards -infinity *)
              begin
              if (sign <> SIGN_POS) then
                begin
                FPU_bits_lost := round_up_24(x, extent);
                end
              else
                begin
                FPU_bits_lost := truncate_24(x, extent);
                end;
              end;

            else
              begin
              //Exception(EX_INTERNAL|$231); manca!!!
              Result := -1;
              Exit;
              end;
            end;
          end;
        end;

      end;

    tag := TAG_Valid;

    if (FPU_denormal) <> 0 then
      begin
      (* Undo the de-normalisation. *)
      if (FPU_denormal = UNMASKED_UNDERFLOW) then
        begin
        if (x^.exp <= EXP_UNDER) then
          begin
          (* Increase the exponent by the magic number *)
          Inc(x^.exp, 3 * (1 shl 13));
          //Exception(EX_Underflow); manca
          end;
        end
      else
        begin
        if (x^.exp <> EXP_UNDER + 1) then
          begin
          //Exception(EX_INTERNAL|$234); manca
          end;
        if ((x^.sigh = 0) and (x^.sigl = 0)) then
          begin
          (* Underflow to zero *)
          // set_precision_flag_down(); manca, vedi in errors.c
          //Exception(EX_Underflow);
          x^.exp := EXP_UNDER;
          tag := TAG_Zero;
          FPU_bits_lost := 0;  (* Stop another call to
             set_precision_flag_down() *)
          end
        else
          begin
          if (x^.sigh and $8000) <> 0 then
            begin
                {$ifdef PECULIAR_486}
  (*
	 * This implements a special feature of 80486 behaviour.
	 * Underflow will be signalled even if the number is
	 * not a denormal after rounding.
	 * This difference occurs only for masked underflow, and not
	 * in the unmasked case.
	 * Actual 80486 behaviour differs from this in some circumstances.
	 *)
                (* Will be masked underflow *)
                {$else}
            (* No longer a denormal *)
                {$endif}
            end
          else
              {$ifndef PECULIAR_486}
            begin
                {$endif}
            Dec(x^.exp);

            if (FPU_bits_lost) <> 0 then
              begin
              (* There must be a masked underflow *)
              //Exception(EX_Underflow); manca
              end;

            tag := TAG_Special;
                {$ifndef PECULIAR_486}
            end;
            {$endif}
          end;
        end;
      end;

    { !!! manca perchè non ci sono ancora le funzioni di errors.c}
    if (FPU_bits_lost = LOST_UP) then
      set_precision_flag_up()
    else
      if (FPU_bits_lost = LOST_DOWN) then
        set_precision_flag_down();

    if (x^.exp >= EXP_OVER) then
      begin
      Inc(x^.exp, EXTENDED_Ebias);
      tag := arith_round_overflow(x, sign);
      end
    else
      begin
      Inc(x^.exp, EXTENDED_Ebias);
      x^.exp := x^.exp and $7fff;
      end;
    if (sign <> SIGN_POS) then
      x^.exp := x^.exp or $8000;

    Result := tag;
  end;

end.
