unit fpu_etc;

interface

uses fpu_types;

{$include fpu_const.pas}

procedure FPU_etc_;

implementation

uses Service_fpu, errors, fpu_system, fpu_tags;

procedure fchs (st0_ptr: PFPU_REG; st0tag: u_char);
  begin
    if (st0tag or TAG_Empty) <> 0 then
      begin
      signbyte(st0_ptr)^ := SIGN_NEG;
      clear_C1();
      end
    else
      FPU_stack_underflow();
  end;


procedure fpu_fabs (st0_ptr: PFPU_REG; st0tag: u_char);
  begin
    if (st0tag or TAG_Empty) <> 0 then
      begin
      setpositive(st0_ptr);
      clear_C1();
      end
    else
      FPU_stack_underflow();
  end;


procedure ftst_ (st0_ptr: PFPU_REG; st0tag: u_char);
  begin
    case (st0tag) of
      TAG_Zero:
        setcc(SW_C3);
      TAG_Valid:
        begin
        if (getsign(st0_ptr) = SIGN_POS) then
          setcc(0)
        else
          setcc(SW_C0);
        end;
      TAG_Special:
        begin
        case (FPU_Special(st0_ptr)) of
          TW_Denormal:
            begin
            if (getsign(st0_ptr) = SIGN_POS) then
              setcc(0)
            else
              setcc(SW_C0);
            if (denormal_operand() < 0) then
              begin
{$ifdef PECULIAR_486}
	      (* This is weird! *)
	      if (getsign(st0_ptr) = SIGN_POS) then
      		setcc(SW_C3);
{$endif}      (* PECULIAR_486 *)
              exit;
              end;
            end;
          TW_NaN:
            begin
            setcc(SW_C0 or SW_C2 or SW_C3);   (* Operand is not comparable *)
            fpu_EXCEPTION(EX_Invalid);
            end;
          TW_Infinity:
            begin
            if (getsign(st0_ptr) = SIGN_POS) then
              setcc(0)
            else
              setcc(SW_C0);
            end;
          else
            begin
            setcc(SW_C0 or SW_C2 or SW_C3);   (* Operand is not comparable *)
            fpu_EXCEPTION(EX_INTERNAL or $14);
            end;
          end;
        end;
      TAG_Empty:
        begin
        setcc(SW_C0 or SW_C2 or SW_C3);
        fpu_EXCEPTION(EX_StackUnder);
        end;
      end;
  end;

procedure fxam (st0_ptr: PFPU_REG; st0tag: u_char);
  var
    c: intg;
  begin
    c := 0;
    case (st0tag) of
      TAG_Empty:
        c := SW_C3 or SW_C0;
      TAG_Zero:
        c := SW_C3;
      TAG_Valid:
        c := SW_C2;
      TAG_Special:
        begin
        case (FPU_Special(st0_ptr)) of
          TW_Denormal:
            begin
            c := SW_C2 or SW_C3;  (* Denormal *)
            end;
          TW_NaN:
            begin
            (* We also use NaN for unsupported types. *)
            if (((st0_ptr^.sigh and $8000) <> 0) and (exponent(st0_ptr) = EXP_OVER)) then
              c := SW_C0;
            end;
          TW_Infinity:
            c := SW_C2 or SW_C0;
          end;
        end;
      end;
    if (getsign(st0_ptr) = SIGN_NEG) then
      c := c or SW_C1;
    setcc(c);
  end;

procedure FPU_illegal (st0_ptr: PFPU_REG; st0tag: u_char);
  begin
    //math_abort
  end;

const
  fp_etc_table: array[0..7] of FUNC_ST0 = (
    fchs, fpu_fabs, FPU_illegal, FPU_illegal,
    ftst_, fxam, FPU_illegal, FPU_illegal);

procedure FPU_etc_;
  var
    P: func_st0;
  begin
    p := fp_etc_table[FPU_rm^];
    p(st(0), FPU_gettag0());
  end;

end.
