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

interface

uses fpu_types;

procedure rem_kernel (st0: u64; y: pu64; st1: u64; q: u64; n: intg);
procedure fcos (st0_ptr: PFPU_REG; st0_tag: u_char);
function fsin (st0_ptr: PFPU_REG; tag: u_char): intg;
procedure fscale (st0_ptr: PFPU_REG; st0_tag: u_char);
procedure FPU_triga;
procedure FPU_trigb;

{$define BETTER_THAN_486}

const
  FCOS_ = 4;

const
  FPTAN_ = 8;

(* Used only by fptan, fsin, fcos, and fsincos. *)
(* This routine produces very accurate results, similar to
   using a value of pi with more than 128 bits precision. *)
(* Limited measurements show no results worse than 64 bit precision
   except for the results for arguments close to 2^63, where the
   precision of the result sometimes degrades to about 63.9 bits *)

{$include fpu_const.pas}

implementation

uses fpu_system, Service_fpu, errors, reg_ld_str, reg_add_sub, fpu_tags,
  reg_convert, poly_2xm1_unit, poly_tan_unit, reg_round, poly_sin_unit,
  reg_mul, poly_l2_unit, poly_atan_unit, Math;

function trig_arg (st0_ptr: PFPU_REG; flags: intg): intg;
  var
    tmp: FPU_REG;
    tmptag: u_char;
    q: u64;
    old_cw, saved_status: intg;
    tag, st0_tag: intg;
  begin
    old_cw  := I387.soft.cwd;
    saved_status := I387.soft.swd;
    st0_tag := TAG_Valid;

    if (exponent(st0_ptr) >= 63) then
      begin
      I387.soft.swd := I387.soft.swd or SW_C2;     (* Reduction incomplete. *)
      Result := -1;
      end;

    if (flags and FPTAN_) <> 0 then
      Inc(st0_ptr^.exp);         (* Effectively base the following upon pi/4 *)

    I387.soft.cwd := I387.soft.cwd and not CW_RC;
    I387.soft.cwd := I387.soft.cwd or RC_CHOP;

    setpositive(st0_ptr);
    tag := FPU_u_div(st0_ptr, @CONST_PI2, @tmp, PR_64_BITS or RC_CHOP or $3f, SIGN_POS);

    FPU_round_to_int(@tmp, tag);  (* Fortunately, this can't overflow
           to 2^64 *)
    q := significand(@tmp)^;

    if (q) <> 0 then
      begin
      rem_kernel(significand(st0_ptr)^, significand(@tmp), significand(@CONST_PI2)^,
        q, exponent(st0_ptr) - exponent(@CONST_PI2));
      setexponent16(@tmp, exponent(@CONST_PI2));
      st0_tag := FPU_normalize_nuo(@tmp, EXTENDED_Ebias);  (* No underflow or overflow
                                                      is possible *)

      FPU_copy_to_reg0(@tmp, st0_tag);
      end;

    if ((flags and FCOS_) <> 0) and ((q and 1) = 0) or
      (((flags and FCOS_) = 0) and ((q and 1) <> 0)) then
      begin
      st0_tag := FPU_sub(REV or LOADED or TAG_Valid, @CONST_PI2, FULL_PRECISION);
      //bbd: arg2 used to typecast to (int)

{$ifdef BETTER_THAN_486}
      (* So far, the results are exact but based upon a 64 bit
   precision approximation to pi/2. The technique used
   now is equivalent to using an approximation to pi/2 which
   is accurate to about 128 bits. *)
      if ((exponent(st0_ptr) <= exponent(@CONST_PI2extra) + 64) or (q > 1)) then
        begin
    (* This code gives the effect of having pi/2 to better than
       128 bits precision. *)

        significand(@tmp)^ := q + 1;
        setexponent16(@tmp, 63);
        FPU_normalize_nuo(@tmp, EXTENDED_Ebias);  (* No underflow or overflow
                                                 is possible *)
        tmptag :=
          FPU_u_mul(@CONST_PI2extra, @tmp, @tmp, FULL_PRECISION,
          SIGN_POS, exponent(@CONST_PI2extra) + exponent(@tmp));
        setsign(@tmp, getsign(@CONST_PI2extra));
        st0_tag := FPU_add(@tmp, tmptag, 0, FULL_PRECISION);
        if ((signnegative(st0_ptr) <> 0) and ((flags and FPTAN_) = 0)) then
          begin
        (* CONST_PI2extra is negative, so the result of the addition
     can be negative. This means that the argument is actually
     in a different quadrant. The correction is always < pi/2,
     so it can't overflow into yet another quadrant. *)
              (* The function is even, so we need just adjust the sign
                 and q. *)
          setpositive(st0_ptr);
          Inc(q);
          end;
        end;
{$endif}(* BETTER_THAN_486 *)
      end
{$ifdef BETTER_THAN_486}
    else
      begin
      (* So far, the results are exact but based upon a 64 bit
   precision approximation to pi/2. The technique used
   now is equivalent to using an approximation to pi/2 which
   is accurate to about 128 bits. *)
      if (((q > 0) and (exponent(st0_ptr) <= exponent(@CONST_PI2extra) + 64)) or
        (q > 1)) then
        begin
    (* This code gives the effect of having p/2 to better than
       128 bits precision. *)

        significand(@tmp)^ := q;
        setexponent16(@tmp, 63);
        FPU_normalize_nuo(@tmp,
          EXTENDED_Ebias);  (* No underflow or overflow
                                                 is possible.
                                                 This must return TAG_Valid *)
        tmptag := FPU_u_mul(@CONST_PI2extra, @tmp, @tmp, FULL_PRECISION,
          SIGN_POS, exponent(@CONST_PI2extra) + exponent(@tmp));
        setsign(@tmp, getsign(@CONST_PI2extra));
        st0_tag := FPU_sub(LOADED or (tmptag and $0f), @tmp, FULL_PRECISION);
        if ((exponent(st0_ptr) = exponent(@CONST_PI2)) and
          ((st0_ptr^.sigh > CONST_PI2.sigh) or
          ((st0_ptr^.sigh = CONST_PI2.sigh) and (st0_ptr^.sigl > CONST_PI2.sigl)))) then
          begin
        (* CONST_PI2extra is negative, so the result of the
     subtraction can be larger than pi/2. This means
     that the argument is actually in a different quadrant.
     The correction is always < pi/2, so it can't overflow
     into yet another quadrant.
           bbd: arg2 used to typecast to (int), corrupting 64-bit ptrs
         *)
          st0_tag := FPU_sub(REV or LOADED or TAG_Valid, @CONST_PI2, FULL_PRECISION);
          Inc(q);
          end;
        end;
      end;
{$endif}(* BETTER_THAN_486 *)

    FPU_settag0(st0_tag);
    I387.soft.cwd := old_cw;
    I387.soft.swd := saved_status and not SW_C2;     (* Reduction complete. *)

    if (flags and FPTAN_) <> 0 then
      begin
      Dec(st0_ptr^.exp);
      Result := q and 7;
      exit;
      end;

    Result := (q and 3) or (flags and FCOS_);
  end;


(* Convert a s32 to register *)
procedure convert_l2reg (arg: ps32; deststnr: intg);
  var
    tag:  intg;
    num:  s32;
    sign: u_char;
    dest: PFPU_REG;
  begin
    dest := st(deststnr);

    if (num = 0) then
      begin
      FPU_copy_to_regi(@CONST_Z, TAG_Zero, deststnr);
      exit;
      end;

    if (num > 0) then
      begin
      sign := SIGN_POS;
      end
    else
      begin
      num  := -num;
      sign := SIGN_NEG;
      end;

    dest^.sigh := num;
    dest^.sigl := 0;
    setexponent16(dest, 31);
    tag := FPU_normalize_nuo(dest, EXTENDED_Ebias);  (* No underflow or overflow
                                              is possible *)
    FPU_settagi(deststnr, tag);
    setsign(dest, sign);
  end;


procedure single_arg_error (st0_ptr: PFPU_REG; st0_tag: u_char);
  begin
    if (st0_tag = TAG_Empty) then
      FPU_stack_underflow()  (* Puts a QNaN in st(0) *)
    else
      if (st0_tag = TW_NaN) then
        real_1op_NaN(st0_ptr);       (* return with a NaN in st(0) *)
{$ifdef PARANOID}
  else
    EXCEPTION(EX_INTERNAL|$0112);
{$endif}(* PARANOID *)
  end;


procedure single_arg_2_error (st0_ptr: PFPU_REG; st0_tag: u_char);
  var
    isNaN: intg;
  begin

    case (st0_tag) of
      TW_NaN:
        begin
        isNaN := word((exponent(st0_ptr) = EXP_OVER) and
          ((st0_ptr^.sigh and $80000000) <> 0));
        if ((isNaN <> 0) and ((st0_ptr^.sigh and $40000000) = 0)) then
          (* Signaling ? *)
          begin
          fpu_EXCEPTION(EX_Invalid);
          if (I387.soft.cwd and CW_Invalid) <> 0 then
            begin
            (* The masked response *)
            (* Convert to a QNaN *)
            st0_ptr^.sigh := st0_ptr^.sigh or $40000000;
            //inc(I387.soft.ftop);
            push();
            FPU_copy_to_reg0(st0_ptr, TAG_Special);
            end;
          end
        else
          if (isNaN) <> 0 then
            begin
            (* A QNaN *)
            push();
            FPU_copy_to_reg0(st0_ptr, TAG_Special);
            end
          else
            begin
            (* pseudoNaN or other unsupported *)
            fpu_EXCEPTION(EX_Invalid);
            if (I387.soft.cwd and CW_Invalid) <> 0 then
              begin
              (* The masked response *)
              FPU_copy_to_reg0(@CONST_QNaN, TAG_Special);
              push();
              FPU_copy_to_reg0(@CONST_QNaN, TAG_Special);
              end;
            end;
        end;              (* return with a NaN in st(0) *)
{$ifdef PARANOID}
    default:
      EXCEPTION(EX_INTERNAL|$0112);
{$endif}(* PARANOID *)
      end;
  end;


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

procedure f2xm1 (st0_ptr: PFPU_REG; tag: u_char);
  var
    a: FPU_REG;
  label
    denormal_arg;
  begin

    clear_C1();

    if (tag = TAG_Valid) then
      begin
      (* For an 80486 FPU, the result is undefined if the arg is >= 1.0 *)
      if (exponent(st0_ptr) < 0) then
        begin
        denormal_arg:

          FPU_to_exp16(st0_ptr, @a);

        (* poly_2xm1(x) requires 0 < st(0) < 1. *)
        poly_2xm1(getsign(st0_ptr), @a, st0_ptr);
        end;
      set_precision_flag_up();   (* 80486 appears to always do this *)
      exit;
      end;

    if (tag = TAG_Zero) then
      exit;

    if (tag = TAG_Special) then
      tag := FPU_Special(st0_ptr);

    case (tag) of
      TW_Denormal:
        begin
        if (denormal_operand() < 0) then
          exit;
        goto denormal_arg;
        end;
      TW_Infinity:
        begin
        if (signnegative(st0_ptr)) <> 0 then
          begin
          (* -infinity gives -1 (p16-10) *)
          FPU_copy_to_reg0(@CONST_1, TAG_Valid);
          setnegative(st0_ptr);
          end;
        end;
      else
        single_arg_error(st0_ptr, tag);
      end;
  end;


procedure fptan (st0_ptr: PFPU_REG; st0_tag: u_char);
  const
    invert: array[0..7] of byte = (0, 1, 1, 0, 0, 1, 1, 0);
  var
    st_new_ptr: PFPU_REG;
    q: u32;
    arg_sign: u_char;

  label
    denormal_arg;
  begin

    (* Stack underflow has higher priority *)
    if (st0_tag = TAG_Empty) then
      begin
      FPU_stack_underflow();  (* Puts a QNaN in st(0) *)
      if (I387.soft.cwd and CW_Invalid) <> 0 then
        begin
        st_new_ptr := st(-1);
        push();
        FPU_stack_underflow();  (* Puts a QNaN in the new st(0) *)
        end;
      exit;
      end;

    if (FPU_stackoverflow(st_new_ptr)) <> 0 then
      begin
      FPU_stack_overflow();
      exit;
      end;

    if (st0_tag = TAG_Valid) then
      begin
      if (exponent(st0_ptr) > -40) then
        begin
        q := trig_arg(st0_ptr, FPTAN_);
        if ((q) = -1) then
          begin
          (* Operand is out of range *)
          exit;
          end;

        poly_tan(st0_ptr, invert[q]);
        setsign(st0_ptr, word(((q and 2) <> 0) or (arg_sign <> 0)));
        set_precision_flag_up();  (* We do not really know if up or down *)
        end
      else
        begin
        (* For a small arg, the result = the argument *)
        (* Underflow may happen *)

        denormal_arg:

          FPU_to_exp16(st0_ptr, st0_ptr);

        st0_tag := FPU_round(st0_ptr, 1, 0, FULL_PRECISION, arg_sign);
        FPU_settag0(st0_tag);
        end;
      push();
      FPU_copy_to_reg0(@CONST_1, TAG_Valid);
      exit;
      end;

    if (st0_tag = TAG_Zero) then
      begin
      push();
      FPU_copy_to_reg0(@CONST_1, TAG_Valid);
      setcc(0);
      exit;
      end;

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

    if (st0_tag = TW_Denormal) then
      begin
      if (denormal_operand() < 0) then
        exit;

      goto denormal_arg;
      end;

    if (st0_tag = TW_Infinity) then
      begin
      (* The 80486 treats infinity as an invalid operand *)
      if (arith_invalid(0) >= 0) then
        begin
        st_new_ptr := st(-1);
        push();
        arith_invalid(0);
        end;
      exit;
      end;

    single_arg_2_error(st0_ptr, st0_tag);
  end;


procedure fxtract (st0_ptr: PFPU_REG; st0_tag: u_char);
  var
    st_new_ptr: PFPU_REG;
    sign: u_char;
    st1_ptr: PFPU_REG;   (* anticipate *)
    e: s32;
  label
    denormal_arg;
  begin
    st1_ptr := st0_ptr;

    st1_ptr := st0_ptr;  (* anticipate *)

    if (FPU_stackoverflow(st_new_ptr)) <> 0 then
      begin
      FPU_stack_overflow();
      exit;
      end;

    clear_C1();

    if (st0_tag = TAG_Valid) then
      begin

      push();
      sign := getsign(st1_ptr);
      reg_copy(st1_ptr, st_new_ptr);
      setexponent16(st_new_ptr, exponent(st_new_ptr));

      denormal_arg:

        e := exponent16(st_new_ptr);
      convert_l2reg(@e, 1);
      setexponentpos(st_new_ptr, 0);
      setsign(st_new_ptr, sign);
      FPU_settag0(TAG_Valid);       (* Needed if arg was a denormal *)
      exit;
      end
    else
      if (st0_tag = TAG_Zero) then
        begin
        sign := getsign(st0_ptr);

        if (FPU_divide_by_zero(0, SIGN_NEG) < 0) then
          exit;

        push();
        FPU_copy_to_reg0(@CONST_Z, TAG_Zero);
        setsign(st_new_ptr, sign);
        exit;
        end;

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

    if (st0_tag = TW_Denormal) then
      begin
      if (denormal_operand() < 0) then
        exit;

      push();
      sign := getsign(st1_ptr);
      FPU_to_exp16(st1_ptr, st_new_ptr);
      goto denormal_arg;
      end
    else
      if (st0_tag = TW_Infinity) then
        begin
        sign := getsign(st0_ptr);
        setpositive(st0_ptr);
        push();
        FPU_copy_to_reg0(@CONST_INF, TAG_Special);
        setsign(st_new_ptr, sign);
        exit;
        end
      else
        if (st0_tag = TW_NaN) then
          begin
          if (real_1op_NaN(st0_ptr) < 0) then
            exit;

          push();
          FPU_copy_to_reg0(st0_ptr, TAG_Special);
          exit;
          end
        else
          if (st0_tag = TAG_Empty) then
            begin
            (* Is this the correct behaviour? *)
            if (I387.soft.cwd and EX_Invalid) <> 0 then
              begin
              FPU_stack_underflow();
              push();
              FPU_stack_underflow();
              end
            else
              fpu_EXCEPTION(EX_StackUnder);
            end;
{$ifdef PARANOID}
  else
    EXCEPTION(EX_INTERNALor$119);
{$endif}(* PARANOID *)
  end;


procedure fdecstp (st0_ptr: PFPU_REG; st0_tag: u_char);
  begin
    clear_C1();
    Dec(I387.soft.ftop);
  end;

procedure fincstp (st0_ptr: PFPU_REG; st0_tag: u_char);
  begin
    clear_C1();
    Inc(I387.soft.ftop);
  end;


procedure fsqrt_ (st0_ptr: PFPU_REG; st0_tag: u_char);
  var
    expon: intg;
    tag: u_char;

  label
    denormal_arg;
  begin

    clear_C1();

    if (st0_tag = TAG_Valid) then
      begin

      if (signnegative(st0_ptr)) <> 0 then
        begin
        arith_invalid(0);  (* sqrt(negative) is invalid *)
        exit;
        end;

      (* make st(0) in  [1.0 .. 4.0) *)
      expon := exponent(st0_ptr);

      denormal_arg:

        setexponent16(st0_ptr, (expon and 1));

      (* Do the computation, the sign of the result will be positive. *)
      tag := wm_sqrt(st0_ptr, 0, 0, I387.soft.cwd, SIGN_POS);
      addexponent(st0_ptr, expon shr 1);
      FPU_settag0(tag);
      exit;
      end;

    if (st0_tag = TAG_Zero) then
      exit;

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

    if (st0_tag = TW_Infinity) then
      begin
      if (signnegative(st0_ptr)) <> 0 then
        arith_invalid(0);  (* sqrt(-Infinity) is invalid *)
      exit;
      end
    else
      if (st0_tag = TW_Denormal) then
        begin
        if (signnegative(st0_ptr)) <> 0 then
          begin
          arith_invalid(0);  (* sqrt(negative) is invalid *)
          exit;
          end;

        if (denormal_operand() < 0) then
          exit;

        FPU_to_exp16(st0_ptr, st0_ptr);

        expon := exponent16(st0_ptr);

        goto denormal_arg;
        end;

    single_arg_error(st0_ptr, st0_tag);

  end;


procedure frndint_ (st0_ptr: PFPU_REG; st0_tag: u_char);
  var
    flags, tag: intg;
    sign: u_char;
  label
    denormal_arg;
  begin

    if (st0_tag = TAG_Valid) then
      begin

      denormal_arg:

        sign := getsign(st0_ptr);

      if (exponent(st0_ptr) > 63) then
        exit;

      if (st0_tag = TW_Denormal) then
        begin
        if (denormal_operand() < 0) then
          exit;
        end;

      (* Fortunately, this can't overflow to 2^64 *)
      flags := FPU_round_to_int(st0_ptr, st0_tag);
      if (flags) <> 0 then
        set_precision_flag(flags);

      setexponent16(st0_ptr, 63);
      tag := FPU_normalize_nuo(st0_ptr, EXTENDED_Ebias);  (* No underflow or overflow
                                                  is possible *)
      setsign(st0_ptr, sign);
      FPU_settag0(tag);
      exit;
      end;

    if (st0_tag = TAG_Zero) then
      exit;

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

    if (st0_tag = TW_Denormal) then
      goto denormal_arg
    else
      if (st0_tag = TW_Infinity) then
        exit
      else
        single_arg_error(st0_ptr, st0_tag);
  end;


function fsin (st0_ptr: PFPU_REG; tag: u_char): intg;
  var
    arg_sign: u_char;
    q: u32;
  begin
    arg_sign := getsign(st0_ptr);

    if (tag = TAG_Valid) then
      begin

      if (exponent(st0_ptr) > -40) then
        begin
        q := trig_arg(st0_ptr, 0);
        if (q = -1) then
          begin
          (* Operand is out of range *)
          Result := 1;
          Exit;
          end;

        poly_sine(st0_ptr);

        if (q and 2) <> 0 then
          changesign(st0_ptr);

        setsign(st0_ptr, getsign(st0_ptr) or arg_sign);

        (* We do not really know if up or down *)
        set_precision_flag_up();
        Result := 0;
        Exit;
        end
      else
        begin
        (* For a small arg, the result = the argument *)
        set_precision_flag_up();  (* Must be up. *)
        Result := 0;
        Exit;
        end;
      end;

    if (tag = TAG_Zero) then
      begin
      setcc(0);
      Result := 0;
      Exit;
      end;

    if (tag = TAG_Special) then
      tag := FPU_Special(st0_ptr);

    if (tag = TW_Denormal) then
      begin
      if (denormal_operand() < 0) then
        begin
        Result := 1;
        Exit;
        end;

      (* For a small arg, the result = the argument *)
      (* Underflow may happen *)
      FPU_to_exp16(st0_ptr, st0_ptr);

      tag := FPU_round(st0_ptr, 1, 0, FULL_PRECISION, arg_sign);

      FPU_settag0(tag);

      Result := 0;
      Exit;
      end
    else
      if (tag = TW_Infinity) then
        begin
        (* The 80486 treats infinity as an invalid operand *)
        arith_invalid(0);
        Result := 1;
        Exit;
        end
      else
        begin
        single_arg_error(st0_ptr, tag);
        Result := 1;
        Exit;
        end;
  end;


function f_cos (st0_ptr: PFPU_REG; tag: u_char): intg;
  var
    st0_sign: u_char;
    q: u32;
  label
    denormal_arg;
  begin

    st0_sign := getsign(st0_ptr);

    if (tag = TAG_Valid) then
      begin

      if (exponent(st0_ptr) > -40) then
        begin
        if ((exponent(st0_ptr) < 0) or ((exponent(st0_ptr) = 0) and
          (significand(st0_ptr)^ <= $c90fdaa22168c234))) then
          begin
          poly_cos(st0_ptr);

          (* We do not really know if up or down *)
          set_precision_flag_down();

          Result := 0;
          Exit;
          end
        else
          begin
          q := trig_arg(st0_ptr, FCOS_);
          if (q <> -1) then
            begin
            poly_sine(st0_ptr);

            if ((q + 1) and 2) <> 0 then
              changesign(st0_ptr);

            (* We do not really know if up or down *)
            set_precision_flag_down();

            Result := 0;
            Exit;
            end
          else
            begin
            (* Operand is out of range *)
            Result := 1;
            Exit;
            end;
          end;
        end
      else
        begin
        denormal_arg:

          setcc(0);
        FPU_copy_to_reg0(@CONST_1, TAG_Valid);
{$ifdef PECULIAR_486}
	  set_precision_flag_down();  (* 80486 appears to do this. *)
{$else}
        set_precision_flag_up();  (* Must be up. *)
{$endif}(* PECULIAR_486 *)
        Result := 0;
        Exit;
        end;
      end
    else
      if (tag = TAG_Zero) then
        begin
        FPU_copy_to_reg0(@CONST_1, TAG_Valid);
        setcc(0);
        Result := 0;
        exit;
        end;

    if (tag = TAG_Special) then
      tag := FPU_Special(st0_ptr);

    if (tag = TW_Denormal) then
      begin
      if (denormal_operand() < 0) then
        begin
        Result := 1;
        Exit;
        end;

      goto denormal_arg;
      end
    else
      if (tag = TW_Infinity) then
        begin
        (* The 80486 treats infinity as an invalid operand *)
        arith_invalid(0);
        Result := 1;
        Exit;
        end
      else
        begin
        single_arg_error(st0_ptr, tag);  (* requires st0_ptr = @st(0) *)
        Result := 1;
        Exit;
        end;
  end;

procedure fcos (st0_ptr: PFPU_REG; st0_tag: u_char);
  begin
    f_cos(st0_ptr, st0_tag);
  end;


procedure fsincos (st0_ptr: PFPU_REG; st0_tag: u_char);
  var
    st_new_ptr: PFPU_REG;
    arg: FPU_REG;
    tag: u_char;
  begin

    (* Stack underflow has higher priority *)
    if (st0_tag = TAG_Empty) then
      begin
      FPU_stack_underflow();  (* Puts a QNaN in st(0) *)
      if (I387.soft.cwd and CW_Invalid) <> 0 then
        begin
        st_new_ptr := st(-1);
        push();
        FPU_stack_underflow();  (* Puts a QNaN in the new st(0) *)
        end;
      exit;
      end;

    if (FPU_stackoverflow(st_new_ptr)) <> 0 then
      begin
      FPU_stack_overflow();
      exit;
      end;

    if (st0_tag = TAG_Special) then
      tag := FPU_Special(st0_ptr)
    else
      tag := st0_tag;

    if (tag = TW_NaN) then
      begin
      single_arg_2_error(st0_ptr, TW_NaN);
      exit;
      end
    else
      if (tag = TW_Infinity) then
        begin
        (* The 80486 treats infinity as an invalid operand *)
        if (arith_invalid(0) >= 0) then
          begin
          (* Masked response *)
          push();
          arith_invalid(0);
          end;
        exit;
        end;

    reg_copy(st0_ptr, @arg);
    if (fsin(st0_ptr, st0_tag)) = 0 then
      begin
      push();
      FPU_copy_to_reg0(@arg, st0_tag);
      f_cos(st(0), st0_tag);
      end
    else
      begin
      (* An error, so restore st(0) *)
      FPU_copy_to_reg0(@arg, st0_tag);
      end;
  end;


 (*---------------------------------------------------------------------------*)
 (* The following all require two arguments: st(0) and st(1) *)

(* A lean, mean kernel for the fprem instructions. This relies upon
   the division and rounding to an integer in do_fprem giving an
   exact result. Because of this, rem_kernel() needs to deal only with
   the least significant 64 bits, the more significant bits of the
   result must be zero.
 *)
procedure rem_kernel (st0: u64; y: Pu64; st1: u64; q: u64; n: intg);
  var
    x: u64;
    work: u64;
  begin

    x := st0 shl n;

    work := u32(st1);
    work := work * u32(q);
    x := x - work;

    work := st1 shr 32;
    work := work * u32(q);
    x := x - work;

    work := u32(st1);
    work := work * q shr 32;
    x := x - work;

    y^ := x;
  end;


(* Remainder of st(0) / st(1) *)
(* This routine produces exact results, i.e. there is never any
   rounding or truncation, etc of the result. *)
procedure do_fprem (st0_ptr: PFPU_REG; st0_tag: u_char; round: intg);
  var
    st1_ptr: PFPU_REG;
    st1_tag: u_char;
    tmp, st0, st1: FPU_REG;
    st0_sign, st1_sign: u_char;
    tmptag: u_char;
    tag: intg;
    old_cw: intg;
    expdif: intg;
    q:  s64;
    saved_status: u16;
    cc: intg;
    sign: u_char;
    x:  u64;
    exp_1, N: intg;
    sign_: u_char;

  label
    fprem_valid;
  begin
    st1_ptr := st(1);
    st1_tag := FPU_gettagi(1);

    if (((st0_tag or TAG_Valid) or (st1_tag or TAG_Valid)) = 0) then
      begin

      fprem_valid:
        (* Convert registers for internal use. *)
        st0_sign := FPU_to_exp16(st0_ptr, @st0);
      st1_sign := FPU_to_exp16(st1_ptr, @st1);
      expdif := exponent16(@st0) - exponent16(@st1);

      old_cw := I387.soft.cwd;
      cc := 0;

      (* We want the status following the denorm tests, but don't want
   the status changed by the arithmetic operations. *)
      saved_status  := I387.soft.swd;
      I387.soft.cwd := I387.soft.cwd and not CW_RC;
      I387.soft.cwd := I387.soft.cwd or RC_CHOP;

      if (expdif < 64) then
        begin
        (* This should be the most common case *)

        if (expdif > -2) then
          begin
          sign_ := st0_sign or st1_sign;
          tag := FPU_u_div(@st0, @st1, @tmp, PR_64_BITS or RC_CHOP or
            $3f, sign_);
          setsign(@tmp, sign_);

          if (exponent(@tmp) >= 0) then
            begin
            FPU_round_to_int(@tmp, tag);  (* Fortunately, this can't
               overflow to 2^64 *)
            q := significand(@tmp)^;

            rem_kernel(significand(@st0)^, @significand(@tmp)^,
              significand(@st1)^,
              q, expdif);

            setexponent16(@tmp, exponent16(@st1));
            end
          else
            begin
            reg_copy(@st0, @tmp);
            q := 0;
            end;

          if ((round = RC_RND) and ((tmp.sigh and $c0000000) <> 0)) then
            begin
      (* We may need to subtract st(1) once more,
         to get a result <= 1/2 of st(1). *)
            expdif := exponent16(@st1) - exponent16(@tmp);
            if (expdif <= 1) then
              begin
              if (expdif = 0) then
                x := significand(@st1)^ - significand(@tmp)^
              else (* expdif is 1 *)
                x := (significand(@st1)^ shl 1) - significand(@tmp)^;
              if ((x < significand(@tmp)^) or
                (* or equi-distant (from 0  and st(1)) and q is odd *)
                ((x = significand(@tmp)^) and ((q and 1) <> 0))) then
                begin
                st0_sign := word(st0_sign = 0);
                significand(@tmp)^ := x;
                Inc(q);
                end;
              end;
            end;

          if (q and 4) <> 0 then
            cc := cc or SW_C0;
          if (q and 2) <> 0 then
            cc := cc or SW_C3;
          if (q and 1) <> 0 then
            cc := cc or SW_C1;
          end
        else
          begin
          I387.soft.cwd := old_cw;
          setcc(0);
          exit;
          end;
        end
      else
        begin
        (* There is a large exponent difference ( >= 64 ) *)
    (* To make much sense, the code in this section should
       be done at high precision. *)

        (* prevent overflow here *)
        (* N is 'a number between 32 and 63' (p26-113) *)
        reg_copy(@st0, @tmp);
        tmptag := st0_tag;
        N := (expdif and $0000001f) + 32;  (* This choice gives results
                identical to an AMD 486 *)
        setexponent16(@tmp, N);
        exp_1 := exponent16(@st1);
        setexponent16(@st1, 0);
        expdif := expdif - N;

        sign_ := getsign(@tmp) or st1_sign;
        tag := FPU_u_div(@tmp, @st1, @tmp, PR_64_BITS or RC_CHOP or $3f, sign_);
        setsign(@tmp, sign_);

        FPU_round_to_int(@tmp, tag);  (* Fortunately, this can't
             overflow to 2^64 *)

        rem_kernel(significand(@st0)^, @significand(@tmp)^,
          significand(@st1)^,
          significand(@tmp)^,
          exponent(@tmp)
          );
        setexponent16(@tmp, exp_1 + expdif);

    (* It is possible for the operation to be complete here.
       What does the IEEE standard say? The Intel 80486 manual
       implies that the operation will never be completed at this
       point, and the behaviour of a real 80486 confirms this.
     *)
        if ((tmp.sigh or tmp.sigl) = 0) then
          begin
          (* The result is zero *)
          I387.soft.cwd := old_cw;
          I387.soft.swd := saved_status;
          FPU_copy_to_reg0(@CONST_Z, TAG_Zero);
          setsign(@st0, st0_sign);
{$ifdef PECULIAR_486}
	      setcc(SW_C2);
{$else}
          setcc(0);
{$endif}  (* PECULIAR_486 *)
          exit;
          end;
        cc := SW_C2;
        end;

      I387.soft.cwd := old_cw;
      I387.soft.swd := saved_status;
      tag := FPU_normalize_nuo(@tmp, 0);
      reg_copy(@tmp, st0_ptr);

      (* The only condition to be looked for is underflow,
   and it can occur here only if underflow is unmasked. *)
      if ((exponent16(@tmp) <= EXP_UNDER) and (tag <> TAG_Zero) and
        ((I387.soft.cwd and CW_Underflow) = 0)) then
        begin
        setcc(cc);
        tag := arith_underflow(st0_ptr);
        setsign(st0_ptr, st0_sign);
        FPU_settag0(tag);
        exit;
        end
      else
        if ((exponent16(@tmp) > EXP_UNDER) or (tag = TAG_Zero)) then
          begin
          stdexp(st0_ptr);
          setsign(st0_ptr, st0_sign);
          end
        else
          begin
          tag := FPU_round(st0_ptr, 0, 0, FULL_PRECISION, st0_sign);
          end;
      FPU_settag0(tag);
      setcc(cc);

      exit;
      end;

    if (st0_tag = TAG_Special) then
      st0_tag := FPU_Special(st0_ptr);
    if (st1_tag = TAG_Special) then
      st1_tag := FPU_Special(st1_ptr);

    if (((st0_tag = TAG_Valid) and (st1_tag = TW_Denormal)) or
      ((st0_tag = TW_Denormal) and (st1_tag = TAG_Valid)) or
      ((st0_tag = TW_Denormal) and (st1_tag = TW_Denormal))) then
      begin
      if (denormal_operand() < 0) then
        exit;
      goto fprem_valid;
      end
    else
      if ((st0_tag = TAG_Empty) or (st1_tag = TAG_Empty)) then
        begin
        FPU_stack_underflow();
        exit;
        end
      else
        if (st0_tag = TAG_Zero) then
          begin
          if (st1_tag = TAG_Valid) then
            begin
            setcc(0);
            exit;
            end
          else
            if (st1_tag = TW_Denormal) then
              begin
              if (denormal_operand() < 0) then
                exit;
              setcc(0);
              exit;
              end
            else
              if (st1_tag = TAG_Zero) then
                begin
                arith_invalid(0);
                exit;
                end (* fprem(?,0) always invalid *)
              else
                if (st1_tag = TW_Infinity) then
                  begin
                  setcc(0);
                  exit;
                  end;
          end
        else
          if ((st0_tag = TAG_Valid) or (st0_tag = TW_Denormal)) then
            begin
            if (st1_tag = TAG_Zero) then
              begin
              arith_invalid(0); (* fprem(Valid,Zero) is invalid *)
              exit;
              end
            else
              if (st1_tag <> TW_NaN) then
                begin
                if (((st0_tag = TW_Denormal) or (st1_tag = TW_Denormal)) and
                  (denormal_operand() < 0)) then
                  exit;

                if (st1_tag = TW_Infinity) then
                  begin
                  (* fprem(Valid,Infinity) is o.k. *)
                  setcc(0);
                  exit;
                  end;
                end;
            end
          else
            if (st0_tag = TW_Infinity) then
              begin
              if (st1_tag <> TW_NaN) then
                begin
                arith_invalid(0); (* fprem(Infinity,?) is invalid *)
                exit;
                end;
              end;

    (* One of the registers must contain a NaN if we got here. *)

{$ifdef PARANOID}
  if ( (st0_tag <> TW_NaN) @ and (st1_tag <> TW_NaN) )
      EXCEPTION(EX_INTERNALor$118);
{$endif}(* PARANOID *)

    real_2op_NaN(st1_ptr, st1_tag, 0, st1_ptr);

  end;


(* ST(1) <- ST(1) * log ST;  pop ST *)
procedure fyl2x (st0_ptr: PFPU_REG; st0_tag: u_char);
  var
    st1_ptr, exponent_: PFPU_REG;
    st1_tag: u_char;
    sign_:  u_char;
    e, tag: intg;
    esign:  u_char;

  label
    both_valid;
  begin
    st1_ptr := st(1);
    st1_tag := FPU_gettagi(1);

    clear_C1();

    if ((st0_tag = TAG_Valid) and (st1_tag = TAG_Valid)) then
      begin
      both_valid:
        (* Both regs are Valid or Denormal *)
        if (signpositive(st0_ptr) <> 0) then
          begin
          if (st0_tag = TW_Denormal) then
            FPU_to_exp16(st0_ptr, st0_ptr)
          else
            (* Convert st(0) for internal use. *)
            setexponent16(st0_ptr, exponent(st0_ptr));

          if ((st0_ptr^.sigh = $80000000) and (st0_ptr^.sigl = 0)) then
            begin
            (* Special case. The result can be precise. *)
            e := exponent16(st0_ptr);
            if (e >= 0) then
              begin
              exponent_.sigh := e;
              esign := SIGN_POS;
              end
            else
              begin
              exponent_.sigh := -e;
              esign := SIGN_NEG;
              end;
            exponent_.sigl := 0;
            setexponent16(@exponent_, 31);
            tag := FPU_normalize_nuo(@exponent_, 0);
            stdexp(@exponent_);
            setsign(@exponent_, esign);
            tag := FPU_mul(@exponent, tag, 1, FULL_PRECISION);
            if (tag >= 0) then
              FPU_settagi(1, tag);
            end
          else
            begin
            (* The usual case *)
            sign_ := getsign(st1_ptr);
            if (st1_tag = TW_Denormal) then
              FPU_to_exp16(st1_ptr, st1_ptr)
            else
              (* Convert st(1) for internal use. *)
              setexponent16(st1_ptr, exponent(st1_ptr));
            poly_l2(st0_ptr, st1_ptr, sign_);
            end;
          end
        else
          begin
          (* negative *)
          if (arith_invalid(1) < 0) then
            exit;
          end;

      FPU_pop();

      exit;
      end;

    if (st0_tag = TAG_Special) then
      st0_tag := FPU_Special(st0_ptr);
    if (st1_tag = TAG_Special) then
      st1_tag := FPU_Special(st1_ptr);

    if ((st0_tag = TAG_Empty) or (st1_tag = TAG_Empty)) then
      begin
      FPU_stack_underflow_pop(1);
      exit;
      end
    else
      if ((st0_tag <= TW_Denormal) and (st1_tag <= TW_Denormal)) then
        begin
        if (st0_tag = TAG_Zero) then
          begin
          if (st1_tag = TAG_Zero) then
            begin
            (* Both args zero is invalid *)
            if (arith_invalid(1) < 0) then
              exit;
            end
          else
            begin
            sign_ := getsign(st1_ptr) xor SIGN_NEG;
            if (FPU_divide_by_zero(1, sign_) < 0) then
              exit;

            setsign(st1_ptr, sign_);
            end;
          end
        else
          if (st1_tag = TAG_Zero) then
            begin
            (* st(1) contains zero, st(0) valid <> 0 *)
            (* Zero is the valid answer *)
            sign_ := getsign(st1_ptr);

            if (signnegative(st0_ptr)) <> 0 then
              begin
              (* log(negative) *)
              if (arith_invalid(1) < 0) then
                exit;
              end
            else
              if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
                exit
              else
                begin
                if (exponent(st0_ptr) < 0) then
                  sign_ := sign_ xor SIGN_NEG;

                FPU_copy_to_reg1(@CONST_Z, TAG_Zero);
                setsign(st1_ptr, sign_);
                end;
            end
          else
            begin
            (* One or both operands are denormals. *)
            if (denormal_operand() < 0) then
              exit;
            goto both_valid;
            end;
        end
      else
        if ((st0_tag = TW_NaN) or (st1_tag = TW_NaN)) then
          begin
          if (real_2op_NaN(st0_ptr, st0_tag, 1, st0_ptr) < 0) then
            exit;
          end
        (* One or both arg must be an infinity *)
        else
          if (st0_tag = TW_Infinity) then
            begin
            if ((signnegative(st0_ptr) <> 0) or (st1_tag = TAG_Zero)) then
              begin
              (* log(-infinity) or 0*log(infinity) *)
              if (arith_invalid(1) < 0) then
                exit;
              end
            else
              begin
              sign_ := getsign(st1_ptr);

              if ((st1_tag = TW_Denormal) and (denormal_operand() < 0)) then
                exit;

              FPU_copy_to_reg1(@CONST_INF, TAG_Special);
              setsign(st1_ptr, sign_);
              end;
            end
          (* st(1) must be infinity here *)
          else
            if (((st0_tag = TAG_Valid) or (st0_tag = TW_Denormal)) and
              (signpositive(st0_ptr) <> 0)) then
              begin
              if (exponent(st0_ptr) >= 0) then
                begin
                if ((exponent(st0_ptr) = 0) and (st0_ptr^.sigh = $80000000) and
                  (st0_ptr^.sigl = 0)) then
                  begin
                  (* st(0) holds 1.0 *)
                  (* infinity*log(1) *)
                  if (arith_invalid(1) < 0) then
                    exit;
                  end;
                (* else st(0) is positive and > 1.0 *)
                end
              else
                begin
                (* st(0) is positive and < 1.0 *)

                if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
                  exit;

                changesign(st1_ptr);
                end;
              end
            else
              begin
              (* st(0) must be zero or negative *)
              if (st0_tag = TAG_Zero) then
                begin
                (* This should be invalid, but a real 80486 is happy with it. *)

{$ifndef PECULIAR_486}
                sign_ := getsign(st1_ptr);
                if (FPU_divide_by_zero(1, sign_) < 0) then
                  exit;
{$endif}        (* PECULIAR_486 *)

                changesign(st1_ptr);
                end
              else
                if (arith_invalid(1) < 0) then    (* log(negative) *)
                  exit;
              end;

    FPU_pop();
  end;


procedure fpatan (st0_ptr: PFPU_REG; st0_tag: u_char);
  var
    st1_ptr: PFPU_REG;
    st1_tag: u_char;
    tag: intg;
    sign_: u_char;

  label
    valid_atan;
  begin
    st1_ptr := st(1);
    st1_tag := FPU_gettagi(1);

    clear_C1();
    if (((st0_tag or TAG_Valid) or (st1_tag or TAG_Valid)) = 0) then
      begin
      valid_atan:

        poly_atan(st0_ptr, st0_tag, st1_ptr, st1_tag);

      FPU_pop();

      exit;
      end;

    if (st0_tag = TAG_Special) then
      st0_tag := FPU_Special(st0_ptr);
    if (st1_tag = TAG_Special) then
      st1_tag := FPU_Special(st1_ptr);

    if (((st0_tag = TAG_Valid) and (st1_tag = TW_Denormal)) or
      ((st0_tag = TW_Denormal) and (st1_tag = TAG_Valid)) or
      ((st0_tag = TW_Denormal) and (st1_tag = TW_Denormal))) then
      begin
      if (denormal_operand() < 0) then
        exit;

      goto valid_atan;
      end
    else
      if ((st0_tag = TAG_Empty) or (st1_tag = TAG_Empty)) then
        begin
        FPU_stack_underflow_pop(1);
        exit;
        end
      else
        if ((st0_tag = TW_NaN) or (st1_tag = TW_NaN)) then
          begin
          if (real_2op_NaN(st0_ptr, st0_tag, 1, st0_ptr) >= 0) then
            FPU_pop();
          exit;
          end
        else
          if ((st0_tag = TW_Infinity) or (st1_tag = TW_Infinity)) then
            begin
            sign_ := getsign(st1_ptr);
            if (st0_tag = TW_Infinity) then
              begin
              if (st1_tag = TW_Infinity) then
                begin
                if (signpositive(st0_ptr) <> 0) then
                  begin
                  FPU_copy_to_reg1(@CONST_PI4, TAG_Valid);
                  end
                else
                  begin
                  setpositive(st1_ptr);
                  tag := FPU_u_add(@CONST_PI4, @CONST_PI2, st1_ptr,
                    FULL_PRECISION, SIGN_POS, exponent(@CONST_PI4),
                    exponent(@CONST_PI2));
                  if (tag >= 0) then
                    FPU_settagi(1, tag);
                  end;
                end
              else
                begin
                if ((st1_tag = TW_Denormal) and (denormal_operand() < 0)) then
                  exit;

                if (signpositive(st0_ptr) <> 0) then
                  begin
                  FPU_copy_to_reg1(@CONST_Z, TAG_Zero);
                  setsign(st1_ptr, sign_);   (* An 80486 preserves the sign_ *)
                  FPU_pop();
                  exit;
                  end
                else
                  begin
                  FPU_copy_to_reg1(@CONST_PI, TAG_Valid);
                  end;
                end;
              end
            else
              begin
              (* st(1) is infinity, st(0) not infinity *)
              if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
                exit;

              FPU_copy_to_reg1(@CONST_PI2, TAG_Valid);
              end;
            setsign(st1_ptr, sign_);
            end
          else
            if (st1_tag = TAG_Zero) then
              begin
              (* st(0) must be valid or zero *)
              sign_ := getsign(st1_ptr);

              if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
                exit;

              if (signpositive(st0_ptr) <> 0) then
                begin
                (* An 80486 preserves the sign_ *)
                FPU_pop();
                exit;
                end;

              FPU_copy_to_reg1(@CONST_PI, TAG_Valid);
              setsign(st1_ptr, sign_);
              end
            else
              if (st0_tag = TAG_Zero) then
                begin
                (* st(1) must be TAG_Valid here *)
                sign_ := getsign(st1_ptr);

                if ((st1_tag = TW_Denormal) and (denormal_operand() < 0)) then
                  exit;

                FPU_copy_to_reg1(@CONST_PI2, TAG_Valid);
                setsign(st1_ptr, sign_);
                end;
{$ifdef PARANOID}
  else
    EXCEPTION(EX_INTERNALor$125);
{$endif}(* PARANOID *)

    FPU_pop();
    set_precision_flag_up();  (* We do not really know if up or down *)
  end;


procedure fprem (st0_ptr: PFPU_REG; st0_tag: u_char);
  begin
    do_fprem(st0_ptr, st0_tag, RC_CHOP);
  end;


procedure fprem1 (st0_ptr: PFPU_REG; st0_tag: u_char);
  begin
    do_fprem(st0_ptr, st0_tag, RC_RND);
  end;


procedure fyl2xp1 (st0_ptr: PFPU_REG; st0_tag: u_char);
  var
    sign_, sign1: u_char;
    st1_ptr, a, b: PFPU_REG;
    st1_tag: u_char;

  label
    valid_yl2xp1;
  begin
    st1_ptr := st(1);
    st1_tag := FPU_gettagi(1);

    clear_C1();
    if (((st0_tag or TAG_Valid) <> 0) or ((st1_tag or TAG_Valid) = 0)) then
      begin
      valid_yl2xp1:

        sign_ := getsign(st0_ptr);
      sign1 := getsign(st1_ptr);

      FPU_to_exp16(st0_ptr, @a);
      FPU_to_exp16(st1_ptr, @b);

      if (poly_l2p1(sign_, sign1, @a, @b, st1_ptr)) <> 0 then
        exit;

      FPU_pop();
      exit;
      end;

    if (st0_tag = TAG_Special) then
      st0_tag := FPU_Special(st0_ptr);
    if (st1_tag = TAG_Special) then
      st1_tag := FPU_Special(st1_ptr);

    if (((st0_tag = TAG_Valid) and (st1_tag = TW_Denormal)) or
      ((st0_tag = TW_Denormal) and (st1_tag = TAG_Valid)) or
      ((st0_tag = TW_Denormal) and (st1_tag = TW_Denormal))) then
      begin
      if (denormal_operand() < 0) then
        exit;

      goto valid_yl2xp1;
      end
    else
      if ((st0_tag = TAG_Empty) or (st1_tag = TAG_Empty)) then
        begin
        FPU_stack_underflow_pop(1);
        exit;
        end
      else
        if (st0_tag = TAG_Zero) then
          begin
          case (st1_tag) of
            TW_Denormal:
              begin
              if (denormal_operand() < 0) then
                exit;
              end;

            TAG_Zero,
            TAG_Valid:
              begin
              setsign(st0_ptr, getsign(st0_ptr) or getsign(st1_ptr));
              FPU_copy_to_reg1(st0_ptr, st0_tag);
              end;

            TW_Infinity:
              begin
              (* Infinity*log(1) *)
              if (arith_invalid(1) < 0) then
                exit;
              end;

            TW_NaN:
              begin
              if (real_2op_NaN(st0_ptr, st0_tag, 1, st0_ptr) < 0) then
                exit;
              end;

            else
{$ifdef PARANOID}
	  EXCEPTION(EX_INTERNALor$116);
	  exit;
{$endif}    (* PARANOID *)
            end;
          end
        else
          if ((st0_tag = TAG_Valid) or (st0_tag = TW_Denormal)) then
            begin
            case (st1_tag) of
              TAG_Zero:
                begin
                if (signnegative(st0_ptr) <> 0) then
                  begin
                  if (exponent(st0_ptr) >= 0) then
                    begin
                    (* st(0) holds <= -1.0 *)
{$ifdef PECULIAR_486}   (* Stupid 80486 doesn't worry about log(negative). *)
		  changesign(st1_ptr);
{$else}
                    if (arith_invalid(1) < 0) then
                      exit;
{$endif}            (* PECULIAR_486 *)
                    end
                  else
                    if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
                      exit
                    else
                      changesign(st1_ptr);
                  end
                else
                  if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
                    exit;
                end;

              TW_Infinity:
                begin
                if (signnegative(st0_ptr) <> 0) then
                  begin
                  if ((exponent(st0_ptr) >= 0) and
                    (((st0_ptr^.sigh = $80000000) and (st0_ptr^.sigl = 0)) = False)) then
                    begin
                    (* st(0) holds < -1.0 *)
{$ifdef PECULIAR_486}   (* Stupid 80486 doesn't worry about log(negative). *)
		  changesign(st1_ptr);
{$else}
                    if (arith_invalid(1) < 0) then
                      exit;
{$endif}            (* PECULIAR_486 *)
                    end
                  else
                    if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
                      exit
                    else
                      changesign(st1_ptr);
                  end
                else
                  if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
                    exit;
                end;

              TW_NaN:
                begin
                if (real_2op_NaN(st0_ptr, st0_tag, 1, st0_ptr) < 0) then
                  exit;
                end;
              end;

            end
          else
            if (st0_tag = TW_NaN) then
              begin
              if (real_2op_NaN(st0_ptr, st0_tag, 1, st0_ptr) < 0) then
                exit;
              end
            else
              if (st0_tag = TW_Infinity) then
                begin
                if (st1_tag = TW_NaN) then
                  begin
                  if (real_2op_NaN(st0_ptr, st0_tag, 1, st0_ptr) < 0) then
                    exit;
                  end
                else
                  if (signnegative(st0_ptr)) <> 0 then
                    begin
{$ifndef PECULIAR_486}
                    (* This should have higher priority than denormals, but... *)
                    if (arith_invalid(1) < 0) then (* log(-infinity) *)
                      exit;
{$endif}            (* PECULIAR_486 *)
                    if ((st1_tag = TW_Denormal) and (denormal_operand() < 0)) then
                      exit;
{$ifdef PECULIAR_486}
	  (* Denormal operands actually get higher priority *)
	  if ( arith_invalid(1) < 0 ) then  (* log(-infinity) *)
	    exit;
{$endif}            (* PECULIAR_486 *)
                    end
                  else
                    if (st1_tag = TAG_Zero) then
                      begin
                      (* log(infinity) *)
                      if (arith_invalid(1) < 0) then
                        exit;
                      end

                    (* st(1) must be valid here. *)

                    else
                      if ((st1_tag = TW_Denormal) and (denormal_operand() < 0)) then
                        exit

      (* The Manual says that log(Infinity) is invalid, but a real
   80486 sensibly says that it is o.k. *)
                      else
                        begin
                        sign_ := getsign(st1_ptr);
                        FPU_copy_to_reg1(@CONST_INF, TAG_Special);
                        setsign(st1_ptr, sign_);
                        end;
                end;
{$ifdef PARANOID}
  else
    begin
      EXCEPTION(EX_INTERNALor$117);
      exit;
    end;
{$endif}(* PARANOID *)

    FPU_pop();
    exit;

  end;


procedure fscale (st0_ptr: PFPU_REG; st0_tag: u_char);
  var
    st1_ptr: PFPU_REG;
    st1_tag: u_char;
    old_cw: intg;
    sign_: u_char;
    scale: s32;
    tmp: FPU_REG;

  label
    valid_scale;
  begin
    st1_ptr := st(1);
    st1_tag := FPU_gettagi(1);
    old_cw := I387.soft.cwd;
    sign_ := getsign(st0_ptr);

    clear_C1();
    if (((st0_tag or TAG_Valid) or (st1_tag or TAG_Valid)) = 0) then
      begin

      (* Convert register for internal use. *)
      setexponent16(st0_ptr, exponent(st0_ptr));

      valid_scale:

        if (exponent(st1_ptr) > 30) then
          begin
          (* 2^31 is far too large, would require 2^(2^30) or 2^(-2^30) *)

          if (signpositive(st1_ptr) <> 0) then
            begin
            fpu_EXCEPTION(EX_Overflow);
            FPU_copy_to_reg0(@CONST_INF, TAG_Special);
            end
          else
            begin
            fpu_EXCEPTION(EX_Underflow);
            FPU_copy_to_reg0(@CONST_Z, TAG_Zero);
            end;
          setsign(st0_ptr, sign_);
          exit;
          end;

      I387.soft.cwd := I387.soft.cwd and not CW_RC;
      I387.soft.cwd := I387.soft.cwd or RC_CHOP;
      reg_copy(st1_ptr, @tmp);
      FPU_round_to_int(@tmp, st1_tag);      (* This can never overflow here *)
      I387.soft.cwd := old_cw;
      scale := ifthen(signnegative(st1_ptr) <> 0, -tmp.sigl, tmp.sigl);
      scale := scale + exponent16(st0_ptr);

      setexponent16(st0_ptr, scale);

      (* Use FPU_round() to properly detect under/overflow etc *)
      FPU_round(st0_ptr, 0, 0, I387.soft.cwd, sign_);

      exit;
      end;

    if (st0_tag = TAG_Special) then
      st0_tag := FPU_Special(st0_ptr);
    if (st1_tag = TAG_Special) then
      st1_tag := FPU_Special(st1_ptr);

    if ((st0_tag = TAG_Valid) or (st0_tag = TW_Denormal)) then
      begin
      case (st1_tag) of
        TAG_Valid:
          begin
          (* st(0) must be a denormal *)
          if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
            exit;

          FPU_to_exp16(st0_ptr, st0_ptr);  (* Will not be left on stack *)
          goto valid_scale;
          end;

        TAG_Zero:
          begin
          if (st0_tag = TW_Denormal) then
            denormal_operand();
          exit;
          end;

        TW_Denormal:
          begin
          denormal_operand();
          exit;
          end;

        TW_Infinity:
          begin
          if ((st0_tag = TW_Denormal) and (denormal_operand() < 0)) then
            exit;

          if (signpositive(st1_ptr) <> 0) then
            FPU_copy_to_reg0(@CONST_INF, TAG_Special)
          else
            FPU_copy_to_reg0(@CONST_Z, TAG_Zero);
          setsign(st0_ptr, sign_);
          exit;
          end;

        TW_NaN:
          begin
          real_2op_NaN(st1_ptr, st1_tag, 0, st0_ptr);
          exit;
          end;
        end;
      end
    else
      if (st0_tag = TAG_Zero) then
        begin
        case (st1_tag) of
          TAG_Valid,
          TAG_Zero:
            exit;

          TW_Denormal:
            begin
            denormal_operand();
            exit;
            end;

          TW_Infinity:
            begin
            if (signpositive(st1_ptr) <> 0) then
              arith_invalid(0); (* Zero scaled by +Infinity *)
            exit;
            end;

          TW_NaN:
            begin
            real_2op_NaN(st1_ptr, st1_tag, 0, st0_ptr);
            exit;
            end;
          end;
        end
      else
        if (st0_tag = TW_Infinity) then
          begin
          case (st1_tag) of
            TAG_Valid,
            TAG_Zero:
              exit;

            TW_Denormal:
              begin
              denormal_operand();
              exit;
              end;

            TW_Infinity:
              begin
              if (signnegative(st1_ptr) <> 0) then
                arith_invalid(0); (* Infinity scaled by -Infinity *)
              end;

            TW_NaN:
              begin
              real_2op_NaN(st1_ptr, st1_tag, 0, st0_ptr);
              exit;
              end;
            end;
          end
        else
          if (st0_tag = TW_NaN) then
            begin
            if (st1_tag <> TAG_Empty) then
              begin
              real_2op_NaN(st1_ptr, st1_tag, 0, st0_ptr);
              exit;
              end;
            end;

{$ifdef PARANOID}
  if ( ((st0_tag = TAG_Empty) or (st1_tag = TAG_Empty)) =0) then
    begin
      fpu_EXCEPTION(EX_INTERNAL or $115);
      exit;
    end;
{$endif}

    (* At least one of st(0), st(1) must be empty *)
    FPU_stack_underflow();

  end;


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

const
  trig_table_a: array[0..7] of FUNC_ST0 = (
    f2xm1, fyl2x, fptan, fpatan,
    fxtract, fprem1, fdecstp, fincstp);


procedure FPU_triga;
  var
    p: FUNC_ST0;
  begin
    p := trig_table_a[FPU_rm^];
    p(st(0), FPU_gettag0());
  end;

procedure fsin__ (st0_ptr: PFPU_REG; st0_tag: u_char);
  begin
    fsin(st0_ptr, st0_tag);
  end;

const
  trig_table_b: array[0..7] of FUNC_ST0 = (
    fprem, fyl2xp1, fsqrt_, fsincos, frndint_, fscale, fsin__, fcos);

procedure FPU_trigb;
  var
    p: FUNC_ST0;
  begin
    p := trig_table_b[FPU_rm^];
    p(st(0), FPU_gettag0());
  end;

end.
