unit reg_compare;

interface

uses fpu_types;

function compare (b: PFPU_REG; tagb: intg): intg;
function FPU_compare_st_data (loaded_data: PFPU_REG; loaded_tag: u_char): intg;
procedure fcom_st ();
procedure fcompst ();
procedure fcompp ();
procedure fucom_ ();
procedure fucompp ();
procedure fucomp ();

implementation

uses Service_fpu, fpu_tags, errors, Math, reg_convert, fpu_system,
  wmfpuemu_Glue;

(*---------------------------------------------------------------------------+
or reg_compare.c                                                            |
or $Id: reg_compare.c,v 1.3 2001/10/06 03:53:46 bdenney Exp $
or                                                                          |
orCompare two floating point registers                                      |
or                                                                          |
orCopyright (C) 1992,1993,1994,1997                                         |
or                 W. Metzenthen, 22 Parker St, Ormond, Vic 3163, Australia |
or                 E-mail   billm@suburbia.net                              |
or                                                                          |
or                                                                          |
 +---------------------------------------------------------------------------*)

(*---------------------------------------------------------------------------+
orcompare() is the core FPU_REG comparison function                         |
 +---------------------------------------------------------------------------*)

function compare (b: PFPU_REG; tagb: intg): intg;
  var
    diff, exp0, expb: intg;
    st0_tag: u_char;
    st0_ptr: PFPU_REG;
    x, y: FPU_REG;
    st0_sign, signb: u_char;
    signalling, unsupported: intg;
  begin
    signb := getsign(b);

    st0_ptr  := st(0);
    st0_tag  := FPU_gettag0();
    st0_sign := getsign(st0_ptr);

    if (tagb = TAG_Special) then
      tagb := FPU_Special(b);
    if (st0_tag = TAG_Special) then
      st0_tag := FPU_Special(st0_ptr);

    if (((st0_tag <> TAG_Valid) and (st0_tag <> TW_Denormal)) or
      ((tagb <> TAG_Valid) and (tagb <> TW_Denormal))) then
      begin
      if (st0_tag = TAG_Zero) then
        begin
        if (tagb = TAG_Zero) then
          begin
          Result := COMP_A_eq_B;
          Exit;
          end;
        if (tagb = TAG_Valid) then
          begin
          Result := ifthen((signb = SIGN_POS), COMP_A_lt_B, COMP_A_gt_B);
          exit;
          end;
        if (tagb = TW_Denormal) then
          begin
          Result := ifthen((signb = SIGN_POS), COMP_A_lt_B, COMP_A_gt_B) or
            COMP_Denormal;
          exit;
          end;
        end
      else
        if (tagb = TAG_Zero) then
          begin
          if (st0_tag = TAG_Valid) then
            begin
            Result := ifthen((st0_sign = SIGN_POS), COMP_A_gt_B, COMP_A_lt_B);
            exit;
            end;
          if (st0_tag = TW_Denormal) then
            begin
            Result := ifthen((st0_sign = SIGN_POS), COMP_A_gt_B, COMP_A_lt_B) or
              COMP_Denormal;
            exit;
            end;
          end;

      if (st0_tag = TW_Infinity) then
        begin
        if ((tagb = TAG_Valid) or (tagb = TAG_Zero)) then
          begin
          Result := ifthen((st0_sign = SIGN_POS), COMP_A_gt_B, COMP_A_lt_B);
          exit;
          end
        else
          if (tagb = TW_Denormal) then
            begin
            Result := ifthen((st0_sign = SIGN_POS), COMP_A_gt_B, COMP_A_lt_B) or
              COMP_Denormal;
            exit;
            end
          else
            if (tagb = TW_Infinity) then
              begin
              (* The 80486 book says that infinities can be equal! *)
              Result := ifthen(st0_sign = signb, COMP_A_eq_B, ifthen(
                (st0_sign = SIGN_POS), COMP_A_gt_B, COMP_A_lt_B));
              exit;
              end;
        (* Fall through to the NaN code *)
        end
      else
        if (tagb = TW_Infinity) then
          begin
          if ((st0_tag = TAG_Valid) or (st0_tag = TAG_Zero)) then
            begin
            Result := ifthen((signb = SIGN_POS), COMP_A_lt_B, COMP_A_gt_B);
            exit;
            end;
          if (st0_tag = TW_Denormal) then
            begin
            Result := ifthen(signb = SIGN_POS, COMP_A_lt_B, COMP_A_gt_B) or
              COMP_Denormal;
            exit;
            end;
          (* Fall through to the NaN code *)
          end;

      (* The only possibility now should be that one of the arguments
   is a NaN *)
      if ((st0_tag = TW_NaN) or (tagb = TW_NaN)) then
        begin
        signalling  := 0;
        unsupported := 0;
        if (st0_tag = TW_NaN) then
          begin
          signalling  := word((st0_ptr^.sigh and $c0000000) = $8000);
          unsupported := word(((exponent(st0_ptr) = EXP_OVER) and
            ((st0_ptr^.sigh and $8000) <> 0)) = False);
          end;
        if (tagb = TW_NaN) then
          begin
          signalling  := signalling or word((b^.sigh and $c0000000) = $8000);
          unsupported := unsupported or word(
            ((exponent(b) = EXP_OVER) and ((b^.sigh and $8000) <> 0)) = False);
          end;
        if (signalling or unsupported) <> 0 then
          begin
          Result := COMP_No_Comp or COMP_SNaN or COMP_NaN;
          exit;
          end
        else
          (* Neither is a signaling NaN *)
          begin
          Result := COMP_No_Comp or COMP_NaN;
          exit;
          end;
        end;

      fpu_EXCEPTION(EX_Invalid);
      end;

    if (st0_sign <> signb) then
      begin
      Result := ifthen(st0_sign = SIGN_POS, COMP_A_gt_B, COMP_A_lt_B) or
        (ifthen((st0_tag = TW_Denormal) or (tagb = TW_Denormal), COMP_Denormal, 0));
      Exit;
      end;

    if ((st0_tag = TW_Denormal) or (tagb = TW_Denormal)) then
      begin
      FPU_to_exp16(st0_ptr, @x);
      FPU_to_exp16(b, @y);
      st0_ptr := @x;
      b := @y;
      exp0 := exponent16(st0_ptr);
      expb := exponent16(b);
      end
    else
      begin
      exp0 := exponent(st0_ptr);
      expb := exponent(b);
      end;

{$ifdef PARANOID}
  if (!(st0_ptr^.sigh  and $8000)) EXCEPTION(EX_Invalid);
  if (!(b^.sigh  and $8000)) EXCEPTION(EX_Invalid);
{$endif}(* PARANOID *)

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

    if (diff > 0) then
      begin
      Result := ifthen((st0_sign = SIGN_POS), COMP_A_gt_B, COMP_A_lt_B) or
        ifthen(((st0_tag = TW_Denormal) or (tagb = TW_Denormal)), COMP_Denormal, 0);
      exit;
      end;
    if (diff < 0) then
      begin
      Result := ifthen((st0_sign = SIGN_POS), COMP_A_lt_B, COMP_A_gt_B) or
        ifthen(((st0_tag = TW_Denormal) or (tagb = TW_Denormal)), COMP_Denormal, 0);
      exit;
      end;

    Result := COMP_A_eq_B or ifthen(
      ((st0_tag = TW_Denormal) or (tagb = TW_Denormal)), COMP_Denormal, 0);

  end;


(* This function requires that st(0) is not empty *)
function FPU_compare_st_data (loaded_data: PFPU_REG; loaded_tag: u_char): intg;
  var
    f, c: intg;
  begin

    c := compare(loaded_data, loaded_tag);

    if (c and COMP_NaN) <> 0 then
      begin
      fpu_EXCEPTION(EX_Invalid);
      f := SW_C3 or SW_C2 or SW_C0;
      end
    else
      case (c and 7) of
        COMP_A_lt_B:
          f := SW_C0;
        COMP_A_eq_B:
          f := SW_C3;
        COMP_A_gt_B:
          f := 0;
        COMP_No_Comp:
          f := SW_C3 or SW_C2 or SW_C0;
{$ifdef PARANOID}
      default:
	EXCEPTION(EX_INTERNAL|$121);
	f := SW_C3orSW_C2orSW_C0;
	break;
{$endif}(* PARANOID *)
        end;
    setcc(f);
    if (c and COMP_Denormal) <> 0 then
      begin
      Result := word(denormal_operand() < 0);
      exit;
      end;
    Result := 0;
  end;

function compare_st_st (nr: intg): intg;
  var
    f, c: intg;
    st_ptr: PFPU_REG;
  begin

    if ((NOT_EMPTY(0) = 0) or (NOT_EMPTY(nr) = 0)) then
      begin
      setcc(SW_C3 or SW_C2 or SW_C0);
      (* Stack fault *)
      fpu_EXCEPTION(EX_StackUnder);
      Result := word((I387.soft.cwd and CW_Invalid) = 0);
      end;

    st_ptr := st(nr);
    c := compare(st_ptr, FPU_gettagi(nr));
    if (c and COMP_NaN) <> 0 then
      begin
      setcc(SW_C3 or SW_C2 or SW_C0);
      fpu_EXCEPTION(EX_Invalid);
      Result := word((I387.soft.cwd and CW_Invalid) = 0);
      end
    else
      case (c and 7) of
        COMP_A_lt_B:
          f := SW_C0;
        COMP_A_eq_B:
          f := SW_C3;
        COMP_A_gt_B:
          f := 0;
        COMP_No_Comp:
          f := SW_C3 or SW_C2 or SW_C0;
{$ifdef PARANOID}
      default:
	EXCEPTION(EX_INTERNAL|$122);
	f := SW_C3orSW_C2orSW_C0;
	break;
{$endif}(* PARANOID *)
        end;
    setcc(f);
    if (c and COMP_Denormal) <> 0 then
      begin
      Result := word(denormal_operand() < 0);
      Exit;
      end;
    Result := 0;
  end;


function compare_u_st_st (nr: intg): intg;
  var
    f, c: intg;
    st_ptr: PFPU_REG;
  begin

    if ((FPU_empty_i(0) = 0) or (FPU_empty_i(nr) = 0)) then
      begin
      setcc(SW_C3 or SW_C2 or SW_C0);
      (* Stack fault *)
      fpu_EXCEPTION(EX_StackUnder);
      Result := word(((I387.soft.cwd <> 0) and (CW_Invalid <> 0)) = False);
      exit;
      end;

    st_ptr := st(nr);
    c := compare(st_ptr, FPU_gettagi(nr));
    if (c and COMP_NaN) <> 0 then
      begin
      setcc(SW_C3 or SW_C2 or SW_C0);
      if (c and COMP_SNaN) <> 0 then      (* This is the only difference between
          un-ordered and ordinary comparisons *)
        begin
        fpu_EXCEPTION(EX_Invalid);
        Result := word(((I387.soft.cwd <> 0) and (CW_Invalid <> 0)) = False);
        exit;
        end;
      Result := 0;
      exit;
      end
    else
      case (c and 7) of
        COMP_A_lt_B:
          f := SW_C0;
        COMP_A_eq_B:
          f := SW_C3;
        COMP_A_gt_B:
          f := 0;
        COMP_No_Comp:
          f := SW_C3 or SW_C2 or SW_C0;
{$ifdef PARANOID}
      default:
	EXCEPTION(EX_INTERNAL|$123);
	f := SW_C3orSW_C2orSW_C0;
	break;
{$endif}(* PARANOID *)
        end;
    setcc(f);
    if (c and COMP_Denormal) <> 0 then
      begin
      Result := word(denormal_operand() < 0);
      exit;
      end;
    Result := 0;
  end;

(*---------------------------------------------------------------------------*)

procedure fcom_st ();
  begin
    (* fcom st(i) *)
    compare_st_st(FPU_rm^);
  end;


procedure fcompst ();
  begin
    (* fcomp st(i) *)
    if (compare_st_st(FPU_rm^) = 0) then
      FPU_pop();
  end;


procedure fcompp ();
  begin
    (* fcompp *)
    if (FPU_rm^ <> 1) then
      begin
      //math_abort(FPU_info,SIGILL); !!! manca
      exit;
      end;
    if (compare_st_st(1) = 0) then
      poppop();
  end;


procedure fucom_ ();
  begin
    (* fucom st(i) *)
    compare_u_st_st(FPU_rm^);

  end;


procedure fucomp ();
  begin
    (* fucomp st(i) *)
    if (compare_u_st_st(FPU_rm^) = 0) then
      FPU_pop();
  end;


procedure fucompp ();
  begin
    (* fucompp *)
    if (FPU_rm^ = 1) then
      begin
      if (compare_u_st_st(1) = 0) then
        poppop();
      end
    else
      FPU_illegal();
  end;

end.
