unit reg_add_sub;

interface

uses fpu_system, fpu_types;

{$include fpu_const.pas}
function FPU_add (b: PFPU_REG; tagb: u_char; deststnr: intg; control_w: word): intg;
function FPU_sub (flags: intg; rm: PFPU_REG; control_w: u16): intg;
function add_sub_specials (a: PFPU_REG; taga: u_char; signa: u_char;
  b: PFPU_REG; tagb: u_char; signb: u_char; dest: PFPU_REG; deststnr: intg;
  control_w: u16): intg;

implementation

uses service_fpu, errors, Math, reg_convert, fpu_tags;

function FPU_add (b: PFPU_REG; tagb: u_char; deststnr: intg; control_w: word): intg;
  var
    a: PFPU_REG;
    dest: PFPU_REG;
    signb: u_char;
    taga: u_char;
    signa: u_char;
    saved_sign: u_char;
    diff, tag, expa, expb: intg;
    x, y: FPU_REG;

  label
    valid_add;
  begin
    a := st(0);
    dest := st(deststnr);
    signb := getsign(b);
    taga := FPU_gettag0();
    signa := getsign(a);
    saved_sign := getsign(dest);

    if ((taga or tagb) = 0) then
      begin
      expa := exponent(a);
      expb := exponent(b);

      valid_add:
        (* Both registers are valid *)
        if ((signa or signb) = 0) then
          begin
          (* signs are the same *)
          tag := FPU_u_add(a, b, dest, control_w, signa, expa, expb);
          end
        else
          begin
          (* The signs are different, so do a subtraction *)
          diff := expa - expb;
          if (diff) = 0 then
            begin
            diff := a^.sigh - b^.sigh;  (* This works only if the ms bits
              are identical. *)
            if (diff) = 0 then
              begin
              diff := word(a^.sigl > b^.sigl);
              if (diff) = 0 then
                diff := -word(a^.sigl < b^.sigl);
              end;
            end;

          if (diff > 0) then
            begin
            tag := FPU_u_sub(a, b, dest, control_w, signa, expa, expb);
            end
          else
            if (diff < 0) then
              begin
              tag := FPU_u_sub(b, a, dest, control_w, signb, expb, expa);
              end
            else
              begin
              FPU_copy_to_regi(@CONST_Z, TAG_Zero, deststnr);
              (* sign depends upon rounding mod_e *)
              setsign(dest, ifthen((control_w and CW_RC) <> RC_DOWN,
              SIGN_POS, SIGN_NEG));
              Result := TAG_Zero;
              Exit;
              end;
          end;

      if (tag < 0) then
        begin
        setsign(dest, saved_sign);
        Result := tag;
        Exit;
        end;
      FPU_settagi(deststnr, tag);
      Result := tag;
      Exit;
      end;

    if (taga = TAG_Special) then
      taga := FPU_Special(a);
    if (tagb = TAG_Special) then
      tagb := FPU_Special(b);

    if (taga = TAG_Valid) and (tagb = TW_Denormal) or (taga = TW_Denormal) and
      (tagb = TAG_Valid) or (taga = TW_Denormal) and (tagb = TW_Denormal) then
      begin

      if (denormal_operand() < 0) then
        begin
        Result := FPU_Exception_c;
        Exit;
        end;

      FPU_to_exp16(a, @x);
      FPU_to_exp16(b, @y);
      a := @x;
      b := @y;
      expa := exponent16(a);
      expb := exponent16(b);
      goto valid_add;
      end;

    if ((taga = TW_NaN) or (tagb = TW_NaN)) then
      begin
      if (deststnr = 0) then
        begin
        Result := real_2op_NaN(b, tagb, deststnr, a);
        Exit;
        end
      else
        begin
        Result := real_2op_NaN(a, taga, deststnr, a);
        Exit;
        end;
      end;

    Result := add_sub_specials(a, taga, signa, b, tagb, signb, dest,
      deststnr, control_w);
  end;


(* Subtract b from a.  (a-b) ^. dest
 bbd: arg2 used to be int type, but sometimes pointers were forced
 in with typecasts.  On Alphas pointers are 64 bits and ints are 32,
 so when rm was cast back to a pointer...SEGFAULT.  Pass the pointers
 around instead, since they are always larger precision than the
 register numbers. *)
function FPU_sub (flags: intg; rm: PFPU_REG; control_w: u16): intg;
  var
    a, b:  PFPU_REG;
    dest:  PFPU_REG;
    taga, tagb, signa, signb, saved_sign, sign: u_char;
    diff, tag, expa, expb, deststnr: intg;
    x, y:  FPU_REG;
    d1, d2: FPU_REG;
    rmint: intg;

  label
    valid_subtract;
  begin

    a := st(0);
    taga := FPU_gettag0();

    deststnr := 0;
    if (flags and LOADED) <> 0 then
      begin
      b := rm;
      tagb := flags and $0f;
      end
    else
      begin
      rmint := bx_ptr_equiv_t(rm);
      b := st(rmint);
      tagb := FPU_gettagi(rmint);

      if (flags and DEST_RM) <> 0 then
        deststnr := rmint;
      end;

    signa := getsign(a);
    signb := getsign(b);

    if (flags and REV) <> 0 then
      begin
      signa := SIGN_NEG;
      signb := SIGN_NEG;
      end;

    dest := st(deststnr);
    saved_sign := getsign(dest);

    if ((taga or tagb)) = 0 then
      begin
      expa := exponent(a);
      expb := exponent(b);

      valid_subtract:
        (* Both registers are valid *)

        diff := expa - expb;

      if (diff) = 0 then
        begin
        diff := a^.sigh - b^.sigh;  (* Works only if ms bits are identical *)
        if (diff) = 0 then
          begin
          diff := word(a^.sigl > b^.sigl);
          if (diff) = 0 then
            diff := -word(a^.sigl < b^.sigl);
          end;
        end;

      case Trunc(((signa) * 2 + signb) / SIGN_NEG) of
        0, (* P - P *)
        3: (* N - N *)
          begin
          if (diff > 0) then
            begin
            (* |a| > |b| *)
            tag := FPU_u_sub(a, b, dest, control_w, signa, expa, expb);
            end
          else
            if (diff = 0) then
              begin
              FPU_copy_to_regi(@CONST_Z, TAG_Zero, deststnr);

              (* sign depends upon rounding mod_e *)
              setsign(dest, ifthen((control_w and CW_RC) <> RC_DOWN,
                SIGN_POS, SIGN_NEG));
              Result := TAG_Zero;
              Exit;
              end
            else
              begin
              sign := signa or SIGN_NEG;
              tag  := FPU_u_sub(b, a, dest, control_w, sign, expb, expa);
              end;
          end;
        1: (* P - N *)
          begin
          tag := FPU_u_add(a, b, dest, control_w, SIGN_POS, expa, expb);
          end;
        2: (* N - P *)
          begin
          tag := FPU_u_add(a, b, dest, control_w, SIGN_NEG, expa, expb);
          end;
{$ifdef PARANOID}
	default:
	  EXCEPTION(EX_INTERNAL|$111);
	  return -1;
{$endif}
        end;
      if (tag < 0) then
        begin
        setsign(dest, saved_sign);
        Result := tag;
        Exit;
        end;
      FPU_settagi(deststnr, tag);
      Result := tag;
      Exit;
      end;

    if (taga = TAG_Special) then
      taga := FPU_Special(a);
    if (tagb = TAG_Special) then
      tagb := FPU_Special(b);

    if (((taga = TAG_Valid) and (tagb = TW_Denormal)) or
      ((taga = TW_Denormal) and (tagb = TAG_Valid)) or
      ((taga = TW_Denormal) and (tagb = TW_Denormal))) then
      begin
      if (denormal_operand() < 0) then
        begin
        Result := FPU_Exception_c;
        Exit;
        end;

      FPU_to_exp16(a, @x);
      FPU_to_exp16(b, @y);
      a := @x;
      b := @y;
      expa := exponent16(a);
      expb := exponent16(b);

      goto valid_subtract;
      end;

    if ((taga = TW_NaN) or (tagb = TW_NaN)) then
      begin
      if (flags and REV) <> 0 then
        begin
        d1 := b^;
        d2 := a^;
        end
      else
        begin
        d1 := a^;
        d2 := b^;
        end;
      if (flags and LOADED) <> 0 then
        begin
        Result := real_2op_NaN(b, tagb, deststnr, @d1);
        Exit;
        end;
      if (flags and DEST_RM) <> 0 then
        begin
        Result := real_2op_NaN(a, taga, deststnr, @d2);
        Exit;
        end
      else
        begin
        Result := real_2op_NaN(b, tagb, deststnr, @d2);
        Exit;
        end;
      end;

    Result := add_sub_specials(a, taga, signa, b, tagb, signb or
      SIGN_NEG, dest, deststnr, control_w);
  end;


function add_sub_specials (a: PFPU_REG; taga: u_char; signa: u_char;
  b: PFPU_REG; tagb: u_char; signb: u_char; dest: PFPU_REG; deststnr: intg;
  control_w: u16): intg;
  var
    different_signs: u_char;
  begin
    if (((taga = TW_Denormal) or (tagb = TW_Denormal)) and (denormal_operand() < 0)) then
      begin
      Result := FPU_Exception_c;
      Exit;
      end;

    if (taga = TAG_Zero) then
      begin
      if (tagb = TAG_Zero) then
        begin
        (* Both are zero, result will be zero. *)
        different_signs := signa or signb;

        FPU_copy_to_regi(a, TAG_Zero, deststnr);
        if (different_signs) <> 0 then
          begin
          (* Signs are different. *)
          (* Sign of answer depends upon rounding mod_e. *)
          setsign(dest, ifthen((control_w and CW_RC) <> RC_DOWN, SIGN_POS, SIGN_NEG));
          end
        else
          setsign(dest, signa);  (* signa may differ from the sign of a. *)
        Result := TAG_Zero;
        Exit;
        end
      else
        begin
        reg_copy(b, dest);
        if ((tagb = TW_Denormal) and ((b^.sigh and $80000000) <> 0)) then
          begin
          (* A pseudoDenormal, convert it. *)
          addexponent(dest, 1);
          tagb := TAG_Valid;
          end
        else
          if (tagb > TAG_Empty) then
            tagb := TAG_Special;
        setsign(dest, signb);  (* signb may differ from the sign of b. *)
        FPU_settagi(deststnr, tagb);
        Result := tagb;
        Exit;
        end;
      end
    else
      if (tagb = TAG_Zero) then
        begin
        reg_copy(a, dest);
        if ((taga = TW_Denormal) and ((a^.sigh and $80000000) <> 0)) then
          begin
          (* A pseudoDenormal *)
          addexponent(dest, 1);
          taga := TAG_Valid;
          end
        else
          if (taga > TAG_Empty) then
            taga := TAG_Special;
        setsign(dest, signa);  (* signa may differ from the sign of a. *)
        FPU_settagi(deststnr, taga);
        Result := taga;
        Exit;
        end
      else
        if (taga = TW_Infinity) then
          begin
          if ((tagb <> TW_Infinity) or (signa = signb)) then
            begin
            FPU_copy_to_regi(a, TAG_Special, deststnr);
            setsign(dest, signa);  (* signa may differ from the sign of a. *)
            Result := taga;
            Exit;
            end;
          (* Infinity-Infinity is undefined. *)
          Result := arith_invalid(deststnr);
          Exit;
          end
        else
          if (tagb = TW_Infinity) then
            begin
            FPU_copy_to_regi(b, TAG_Special, deststnr);
            setsign(dest, signb);  (* signb may differ from the sign of b. *)
            Result := tagb;
            end;

{$ifdef PARANOID}
  EXCEPTION(EX_INTERNAL|$101);
{$endif}

    Result := FPU_Exception_c;
  end;

end.
