unit errors;

interface

uses fpu_types;


 //procedure Un_impl;
 //procedure FPU_illegal;
 //procedure FPU_printall;
procedure FPU_exception (n: intg);
function real_1op_NaN (a: PFPU_REG): intg;
function real_2op_NaN (b: PFPU_REG; tagb: u_char; deststnr: intg;
  defaultNaN: PFPU_REG): intg;
function arith_invalid (deststnr: intg): intg;
function FPU_divide_by_zero (deststnr: intg; sign: u_char): intg;
function set_precision_flag (flags: intg): intg;
procedure set_precision_flag_up;
procedure set_precision_flag_down;
function denormal_operand: intg;
function arith_overflow (dest: PFPU_REG): intg;
function arith_round_overflow (dest: PFPU_REG; sign: u8): intg;
function arith_underflow (dest: PFPU_REG): intg;
procedure FPU_stack_overflow;
procedure FPU_stack_underflow;
procedure FPU_stack_underflow_i (i: intg);
procedure FPU_stack_underflow_pop (i: intg);
function NOT_EMPTY (stnr: intg): intg;

{ fpu_arith.c }
procedure fadd__;
procedure fadd_i;
procedure faddp_;
procedure fmul__;
procedure fmul_i;
procedure fmulp_;
procedure fsub__;
procedure fsubri;
procedure fsubrp;
procedure fsubr_;
procedure fsub_i;
procedure fsubp_;
procedure fdiv__;
procedure fdivri;
procedure fdivrp;
procedure fdivr_;
procedure fdiv_i;
procedure fdivp_;
(*
{ fpu_aux.c }
procedure fclex;
procedure finit;
procedure finit_;
procedure fstsw_;
procedure fp_nop;
procedure fld_i_;
procedure fxch_i;
procedure ffree_;
procedure ffreep;
procedure fst_i_;
procedure fstp_i;
{ fpu_entry.c }
procedure math_emulate(arg:long);
procedure math_abort(info:pinfo; signal:word);
{ fpu_etc.c }
procedure FPU_etc;
{ fpu_tags.c }*)
function FPU_gettagi (stnr: intg): intg;
function FPU_gettag (regnr: intg): intg;
(*procedure FPU_settag0(tag:intg);*)
procedure FPU_settagi (stnr: intg; tag: intg);
(*procedure FPU_settag(regnr:intg;tag:intg);*)
function FPU_Special (ptr: PFPU_REG): intg;
(*function isNaN(ptr:PFPU_REG):intg;*)
procedure FPU_pop;
function FPU_empty_i (stnr: intg): intg;
(*function FPU_stackoverflow(st_new_ptr:PFPU_REG):intg;
procedure FPU_sync_tags;  *)
procedure FPU_copy_to_regi (r: PFPU_REG; tag: u_char; stnr: intg);
(*procedure FPU_copy_to_reg1(r:PFPU_REG; tag:u_char);*)
procedure FPU_copy_to_reg0 (r: PFPU_REG; tag: u_char);
{ fpu_trig.c }
(*procedure FPU_triga;
procedure FPU_trigb;
{ get_address.c }
function FPU_get_address(FPU_modrm:u_char; fpu_eip:pu32; addr:paddress; addr_modes:fpu_addr_modes):pointer;
function FPU_get_address_16(FPU_modrm:u_char; fpu_eip:pu32; addr:paddress; addr_modes:fpu_addr_modes):pointer;
{ load_store.c }
function FPU_load_store(type_:u_char; addr_modes:fpu_addr_modes; data_address:pointer):intg;
{ poly_2xm1.c }
function poly_2xm1(sign:u_char; arg:PFPU_REG; result:PFPU_REG):intg;
{ poly_atan.c }
procedure poly_atan(st0_ptr:PFPU_REG; st0_tag:u_char; st1_ptr:PFPU_REG; st1_tag:u_char);
{ poly_l2.c }
procedure poly_l2(st0_ptr:PFPU_REG; st1_ptr:PFPU_REG; st1_sign:u_char);
function poly_l2p1(s0:u_char; s1:u_char; r0:PFPU_REG; r1:PFPU_REG; d:PFPU_REG):intg;
{ poly_sin.c }
procedure poly_sine(st0_ptr:PFPU_REG);
procedure poly_cos(st0_ptr:PFPU_REG);
{ poly_tan.c }
procedure poly_tan(st0_ptr:PFPU_REG; flag:intg);
{ reg_add_sub.c }
function FPU_add(b:PFPU_REG; tagb:u_char; destrnr:intg; control_w:u16):intg;
function FPU_sub(flags:intg; rm:PFPU_REG; control_w:u16):intg;   // bbd: changed arg2 from intg to FPU_REG*
{ reg_compare.c }
function FPU_compare_st_data(loaded_data:PFPU_REG; loaded_tag:u_char):intg;
procedure fcom_st;
procedure fcompst;
procedure fcompp;
procedure fucom_;
procedure fucomp;
procedure fucompp;
{ reg_constant.c }
procedure fconst;
{ reg_ld_str.c }
function FPU_load_extended(s:pextended; stnr:intg):intg;
function FPU_load_double(dfloat:pdouble; loaded_data:PFPU_REG):intg;
function FPU_load_single(single:psingle; loaded_data:PFPU_REG):intg;
function FPU_load_int64(_s:ps64):intg;
function FPU_load_int32(_s:ps32; loaded_data:PFPU_REG):intg;
function FPU_load_int16(_s:ps16; loaded_data:PFPU_REG):intg;
function FPU_load_bcd(s:pu_char):intg;
function FPU_store_extended(st0_ptr:PFPU_REG; st0_tag:u_char; d:pextended):intg;
function FPU_store_double(st0_ptr:PFPU_REG; st0_tag:u_char; dfloat:pdouble):intg;
function FPU_store_single(st0_ptr:PFPU_REG; st0_tag:u_char; single:psingle):intg;
function FPU_store_int64(st0_ptr:PFPU_REG; st0_tag:u_char; d:ps64):intg;
function FPU_store_int32(st0_ptr:PFPU_REG; st0_tag:u_char; d:ps32):intg;
function FPU_store_int16(st0_ptr:PFPU_REG; st0_tag:u_char; d:ps16):intg;
function FPU_store_bcd(st0_ptr:PFPU_REG; st0_tag:u_char; d:pu_char):intg;
function FPU_round_to_int(r:PFPU_REG; tag:u_char):intg;
function fldenv(addr_modes:fpu_addr_modes; s:pu_char):pu_char;
procedure frstor(addr_modes:fpu_addr_modes; data_address:pu_char);
function  fstenv(addr_modes:fpu_addr_modes; d:pu_char):pu_char;
procedure fsave(addr_modes:fpu_addr_modes; data_address:pu_char);
function FPU_tagof(ptr:PFPU_REG):intg;
{ reg_mul.c }
function FPU_mul(b:PFPU_REG; tagb:u_char; deststnr:intg; control_w:intg):intg;

function FPU_div(flags:intg; regrm:PFPU_REG; control_w:intg):intg; // bbd: changed arg2 from intg to FPU_REG*
{ reg_convert.c }
function FPU_to_exp16(a:PFPU_REG; x:PFPU_REG):intg;*)

procedure printk (fmt: string);

type

  texception_names = record
    type_: Intg;
    Name:  string;
  end;

{$include fpu_const.pas}

const
  exception_names: array[0..9] of texception_names = (
    (type_: EX_StackOver; Name: 'stack overflow'),
    (type_: EX_StackUnder; Name: 'stack underflow'),
    (type_: EX_Precision; Name: 'loss of precision'),
    (type_: EX_Underflow; Name: 'underflow'),
    (type_: EX_Overflow; Name: 'overflow'),
    (type_: EX_ZeroDiv; Name: 'divide by zero'),
    (type_: EX_Denormal; Name: 'denormalized operand'),
    (type_: EX_Invalid; Name: 'invalid operation'),
    (type_: EX_INTERNAL; Name: 'INTERNAL BUG in FPU_VERSION'),
    (type_: 0; Name: ''));


implementation

uses SysUtils, service, fpu_system, Math, Service_fpu, reg_add_sub, reg_mul,
  reg_divide, fpu_tags, reg_convert;

{$include status_w.pas}

procedure printk (fmt: string);
  begin
    BX_INFO(fmt);
  end;

procedure FPU_exception (n: intg);
  var
    i, int_type: intg;
  begin

    int_type := 0;         (* Needed only to stop compiler warnings *)
    if (n and EX_INTERNAL) <> 0 then
      begin
      int_type := n - EX_INTERNAL;
      n := EX_INTERNAL;
      (* Set lots of exception bits! *)
      I387.soft.swd := I387.soft.swd or (SW_Exc_Mask or SW_Summary or SW_Backward);
      end
    else
      begin
      (* Extract only the bits which we use to set the status word *)
      n := n and (SW_Exc_Mask);
      (* Set the corresponding exception bit *)
      I387.soft.swd := I387.soft.swd or n;
      (* Set summary bits iff exception isn't masked *)
      if (I387.soft.swd and not I387.soft.cwd and CW_Exceptions) <> 0 then
        I387.soft.swd := I387.soft.swd or (SW_Summary or SW_Backward);
      if (n and (SW_Stack_Fault or EX_Precision)) <> 0 then
        begin
        if ((n and SW_C1)) = 0 then
            (* This bit distinguishes over- from underflow for a stack fault,
             and roundup from round-down for precision loss. *)
          I387.soft.swd := I387.soft.swd and not SW_C1;
        end;
      end;

    //RE_ENTRANT_CHECK_OFF;
    if ((not I387.soft.cwd and n and CW_Exceptions) <> 0) or (n = EX_INTERNAL) then
      begin
{$ifdef PRINT_MESSAGES}
      (* My message from the sponsor *)
      printk(FPU_VERSION' '__DATE__' (C) W. Metzenthen.\n');
{$endif}(* PRINT_MESSAGES *)

      (* Get a name string for error reporting *)
(*      for i:=0 to exception_names[i].type_ do
        if ( (exception_names[i].type_ and n) = exception_names[i].type_ ) then
          break;

      if (exception_names[i].type_)<>0 then
  begin
  end
      else
  printk(Format('FPU emulator: Unknown Exception: $%04x!\n',[n]));*)

      if (n = EX_INTERNAL) then
        begin
        printk(Format('FPU emulator: Internal error type $%04x\n', [int_type]));
        //FPU_printall();
        end;
{$ifdef PRINT_MESSAGES}
      else
	FPU_printall();
{$endif}(* PRINT_MESSAGES *)

      (*
       * The 80486 generates an interrupt on the next non-control FPU
       * instruction. So we need some means of flagging it.
       * We use the ES (Error Summary) bit for this.
       *)
      end;
    //RE_ENTRANT_CHECK_ON;

  end;


 (* Real operation attempted on a NaN. *)
 (* Returns < 0 if the exception is unmasked *)
function real_1op_NaN (a: PFPU_REG): intg;
  var
    signalling, isNaN: intg;
    cond: boolean;
  begin

    cond  := (((a^.exp and $7fff) - EXTENDED_Ebias) = EXP_OVER) and
      ((a^.sigh and $8000) <> 0);
    isNaN := word(cond);

  (* The default result for the case of two 'equal' NaNs (signs may
     differ) is chosen to reproduce 80486 behaviour *)
    signalling := word((isNaN <> 0) and ((a^.sigh and $40000000) = 0));

    if (signalling = 0) then
      begin
      if (isNaN) = 0 then (* pseudo-NaN, or other unsupported? *)
        begin
        if (I387.soft.cwd and CW_Invalid) <> 0 then
          begin
          (* Masked response *)
          reg_copy(@CONST_QNaN, a);
          end;
        fpu_EXCEPTION(EX_Invalid);
        cond := ifthen((I387.soft.cwd and CW_Invalid) <> 0, FPU_Exception_c, 0) = 0;
        Result := word(cond) or TAG_Special;
        end;
      Result := TAG_Special;
      end;

    if (I387.soft.cwd and CW_Invalid) <> 0 then
      begin
      (* The masked response *)
      if ((a^.sigh and $8000) = 0) then  (* pseudo-NaN ? *)
        begin
        reg_copy(@CONST_QNaN, a);
        end;
      (* ensure a Quiet NaN *)
      a^.sigh := a^.sigh or $40000000;
      end;

    fpu_exception(EX_Invalid);

    cond := ifthen((I387.soft.cwd and CW_Invalid) <> 0, FPU_Exception_c, 0) = 0;
    Result := word(cond) or TAG_Special;
  end;

function FPU_gettag (regnr: intg): intg;
  begin
    Result := (I387.soft.twd shr ((regnr and 7) * 2)) and 3;
  end;

function FPU_gettagi (stnr: intg): intg;
  begin
    Result := (I387.soft.twd shr (((I387.soft.ftop + stnr) and 7) * 2)) and 3;
  end;

function FPU_Special (ptr: PFPU_REG): intg;
  var
    exp: intg;
  begin
    exp := exponent(ptr);

    Result := TW_NaN;
    if (exp = EXP_BIAS + EXP_UNDER) then
      Result := TW_Denormal
    else
      if (exp <> EXP_BIAS + EXP_OVER) then
        Result := TW_NaN
      else
        if ((ptr^.sigh = $80000000) and (ptr^.sigl = 0)) then
          Result := TW_Infinity;
  end;

procedure FPU_settagi (stnr: intg; tag: intg);
  var
    regnr: intg;
  begin
    regnr := stnr + top;
    regnr := regnr and 7;
    I387.soft.twd := I387.soft.twd and not (3 shl (regnr * 2));
    I387.soft.twd := I387.soft.twd or (tag and 3) shl (regnr * 2);
  end;

procedure FPU_copy_to_regi (r: PFPU_REG; tag: u_char; stnr: intg);
  var
    p: pointer;
  begin
    P := st(stnr);
    reg_copy(r, P);
    FPU_settagi(stnr, tag);
  end;

procedure FPU_copy_to_reg0 (r: PFPU_REG; tag: u_char);
  var
    regnr: intg;
    p: pointer;
  begin
    regnr := top;
    regnr := regnr and 7;

    P := st(0);
    reg_copy(r, P);

    I387.soft.twd := I387.soft.twd and not (3 shl (regnr * 2));
    I387.soft.twd := I387.soft.twd or (tag and 3) shl (regnr * 2);
  end;

function real_2op_NaN (b: PFPU_REG; tagb: u_char; deststnr: intg;
  defaultNaN: PFPU_REG): intg;
  var
    dest: PFPU_REG;
    a: PFPU_REG;
    taga: u_char;
    x: PFPU_REG;
    signalling, unsupported: intg;
    p: pointer;
  begin

    p := st(deststnr);
    dest := P;
    a := dest;
    taga := FPU_gettagi(deststnr);

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

    (* TW_NaN is also used for unsupported data types. *)
    unsupported := word((taga = TW_NaN) and (exponent(a) = EXP_OVER) and
      ((a^.sigh and $80000000) = 0) or (tagb = TW_NaN) and
      (exponent(b) = EXP_OVER) and ((b^.sigh and $80000000) = 0));
    if (unsupported) <> 0 then
      begin
      if (I387.soft.cwd and CW_Invalid) <> 0 then
        begin
        (* Masked response *)
        FPU_copy_to_regi(@CONST_QNaN, TAG_Special, deststnr);
        end;
      fpu_exception(EX_Invalid);
      Result := word(ifthen((I387.soft.cwd and CW_Invalid) <> 0,
        FPU_Exception_c, 0) = 0);
      end;

    if (taga = TW_NaN) then
      begin
      x := a;
      if (tagb = TW_NaN) then
        begin
        signalling := word((a^.sigh and b^.sigh and $40000000) = 0);
        if (significand(b)^ > significand(a)^) then
          x := b
        else
          if (significand(b)^ = significand(a)^) then
            begin
              (* The default result for the case of two 'equal' NaNs (signs may
              differ) is chosen to reproduce 80486 behaviour *)
            x := defaultNaN;
            end;
        end
      else
        begin
        (* return the quiet version of the NaN in a *)
        signalling := word((a^.sigh and $40000000) = 0);
        end;
      end
    else
{$ifdef PARANOID}
    if (tagb = TW_NaN) then
{$endif}(* PARANOID *)
      begin
      signalling := word((b^.sigh and $40000000) = 0);
      x := b;
      end;
{$ifdef PARANOID}
  else
    begin
      signalling := 0;
      fpu_EXCEPTION(EX_INTERNAL|$113);
      x := @CONST_QNaN;
    end;
{$endif}(* PARANOID *)

    if ((signalling = 0) or ((I387.soft.cwd and CW_Invalid) <> 0)) then
      begin
      if (x = nil) then
        x := b;
      if ((x^.sigh and $80000000) = 0) then  (* pseudo-NaN ? *)
        x := @CONST_QNaN;
      FPU_copy_to_regi(x, TAG_Special, deststnr);
      if (signalling = 0) then
        begin
        Result := TAG_Special;
        Exit;
        end;
      (* ensure a Quiet NaN *)
      dest^.sigh := dest^.sigh or $40000000;
      end;

    fpu_EXCEPTION(EX_Invalid);

    Result := word(ifthen((I387.soft.cwd and CW_Invalid) <> 0, FPU_Exception_c, 0) =
      0) or TAG_Special;
  end;

function arith_invalid (deststnr: intg): intg;
  begin
    fpu_EXCEPTION(EX_Invalid);

    if (I387.soft.cwd and CW_Invalid) <> 0 then
      begin
      // The masked response
      FPU_copy_to_regi(@CONST_QNaN, TAG_Special, deststnr);
      end;

    Result := word(ifthen((I387.soft.cwd and CW_Invalid) <> 0, FPU_Exception_c, 0) =
      0) or TAG_Valid;
  end;

function FPU_divide_by_zero (deststnr: intg; sign: u_char): intg;
  var
    dest: PFPU_REG;
    tag:  intg;
  begin
    dest := st(deststnr);
    tag  := TAG_Valid;

    if (I387.soft.cwd and CW_ZeroDiv) <> 0 then
      begin
      //The masked response
      FPU_copy_to_regi(@CONST_INF, TAG_Special, deststnr);
      setsign(dest, sign);
      tag := TAG_Special;
      end;

    fpu_exception(EX_ZeroDiv);

    Result := word(ifthen((I387.soft.cwd and CW_ZeroDiv) <> 0,
      FPU_Exception_c, 0) = 0) or tag;
  end;

function set_precision_flag (flags: intg): intg;
  begin
    if (I387.soft.cwd and CW_Precision) <> 0 then
      begin
      I387.soft.swd := I387.soft.swd and not (SW_C1 and flags);
      I387.soft.swd := I387.soft.swd or flags;   // The masked response
      Result := 0;
      end
    else
      begin
      fpu_exception(flags);
      Result := 1;
      end;
  end;

procedure set_precision_flag_up;
  begin
    if (I387.soft.cwd and CW_Precision) <> 0 then
      I387.soft.swd := I387.soft.swd or (SW_Precision or SW_C1)   // The masked response
    else
      fpu_exception(EX_Precision or SW_C1);
  end;

procedure set_precision_flag_down;
  begin
    if (I387.soft.cwd and CW_Precision) <> 0 then
      begin   // The masked response
      I387.soft.swd := I387.soft.swd and not SW_C1;
      I387.soft.swd := I387.soft.swd or SW_Precision;
      end
    else
      fpu_exception(EX_Precision);
  end;

function denormal_operand: intg;
  begin
    if (I387.soft.cwd and CW_Denormal) <> 0 then
      begin   // The masked response
      I387.soft.swd := I387.soft.swd or SW_Denorm_Op;
      Result := TAG_Special;
      end
    else
      begin
      fpu_exception(EX_Denormal);
      Result := TAG_Special or FPU_Exception_c;
      end;
  end;

function arith_overflow (dest: PFPU_REG): intg;
  var
    tag: intg;
  begin
    tag := TAG_Valid;

    if (I387.soft.cwd and CW_Overflow) <> 0 then
      begin
      // The masked response
      reg_copy(@CONST_INF, dest);
      tag := TAG_Special;
      end
    else
      begin
      // Subtract the magic number from the exponent
      addexponent(dest, (-3 * (1 shl 13)));
      end;

    fpu_exception(EX_Overflow);
    if (I387.soft.cwd and CW_Overflow) <> 0 then
      begin
      { The overflow exception is masked. }
      { By definition, precision is lost.
   The roundup bit (C1) is also set because we have
   "rounded" upwards to Infinity. }
      fpu_exception(EX_Precision or SW_C1);
      Result := tag;
      end;

    Result := tag;
  end;

function arith_round_overflow (dest: PFPU_REG; sign: u8): intg;
  var
    tag, largest: intg;
  begin
    tag := TAG_Valid;

    if (I387.soft.cwd and CW_Overflow) <> 0 then
      begin
      //The masked response */
      // The response here depends upon the rounding mode */
      case (I387.soft.cwd and CW_RC) of
        RC_CHOP:    // Truncate */
          begin
          largest := 1;
          end;
        RC_UP:    // Towards +infinity */
          begin
          largest := word(sign = SIGN_NEG);
          end;
        RC_DOWN:    // Towards -infinity */
          begin
          largest := word(sign = SIGN_POS);
          end;
        else
          begin
          largest := 0;
          end;
        end;
      if (largest = 0) then
        begin
        reg_copy(@CONST_INF, dest);
        tag := TAG_Special;
        end
      else
        begin
        dest^.exp := EXTENDED_Ebias + EXP_OVER - 1;
        case (I387.soft.cwd and CW_PC) of
          01,
          PR_64_BITS:
            pu64(@dest^.sigh)^ := $ffffffffffffffff;
          PR_53_BITS:
            pu64(@dest^.sigh)^ := $fffffffffffff800;
          PR_24_BITS:
            pu64(@dest^.sigh)^ := $ffffff0000000000;
          end;
        end;
      end
    else
      begin
      // Subtract the magic number from the exponent */
      addexponent(@dest, (-3 * (1 shl 13)));
      largest := 0;
      end;

    fpu_EXCEPTION(EX_Overflow);
    if (I387.soft.cwd and CW_Overflow) <> 0 then
      begin
      // The overflow exception is masked.
      if (largest) <> 0 then
        begin
        fpu_EXCEPTION(EX_Precision);
        end
      else
        begin
        // By definition, precision is lost.
        //The roundup bit (C1) is also set because we have
        //"rounded" upwards to Infinity. */
        fpu_EXCEPTION(EX_Precision or SW_C1);
        end;
      Result := tag;
      exit;
      end;

    Result := tag;
  end;

function arith_underflow (dest: PFPU_REG): intg;
  var
    tag: intg;
  begin
    tag := TAG_Valid;

    if (I387.soft.cwd and CW_Underflow) <> 0 then
      begin
      // The masked response */
      if (exponent16(dest) <= EXP_UNDER - 63) then
        begin
        reg_copy(@CONST_Z, dest);
        I387.soft.swd := I387.soft.swd and not SW_C1;       // Round down. */
        tag := TAG_Zero;
        end
      else
        begin
        stdexp(dest);
        end;
      end
    else
      begin
      // Add the magic number to the exponent. */
      addexponent(dest, (3 * (1 shl 13)) + EXTENDED_Ebias);
      end;

    fpu_EXCEPTION(EX_Underflow);
    if (I387.soft.cwd and CW_Underflow) <> 0 then
      begin
      // The underflow exception is masked. */
      fpu_EXCEPTION(EX_Precision);
      Result := tag;
      exit;
      end;

    Result := tag;

  end;

procedure FPU_stack_overflow;
  begin
    if (I387.soft.cwd and CW_Invalid) <> 0 then
      begin
      // The masked response */
      Dec(I387.soft.ftop);
      FPU_copy_to_reg0(@CONST_QNaN, TAG_Special);
      end;

    fpu_EXCEPTION(EX_StackOver);

  end;

procedure FPU_stack_underflow;
  begin
    if (I387.soft.cwd and CW_Invalid) <> 0 then
      begin
      // The masked response */
      FPU_copy_to_reg0(@CONST_QNaN, TAG_Special);
      end;

    fpu_EXCEPTION(EX_StackUnder);
  end;

procedure FPU_stack_underflow_i (i: intg);
  begin
    if (I387.soft.cwd and CW_Invalid) <> 0 then
      begin
      // The masked response */
      FPU_copy_to_regi(@CONST_QNaN, TAG_Special, i);
      end;

    fpu_EXCEPTION(EX_StackUnder);
  end;

procedure FPU_stack_underflow_pop (i: intg);
  begin
    if (I387.soft.cwd and CW_Invalid) <> 0 then
      begin
      // The masked response */
      FPU_copy_to_regi(@CONST_QNaN, TAG_Special, i);
      FPU_pop();
      end;

    fpu_EXCEPTION(EX_StackUnder);
  end;

procedure fadd__ ();
  var
    i: intg;
  begin
    (* fadd st,st(i) *)
    i := fpu_rm^;
    clear_C1();
    FPU_add(st(i), FPU_gettagi(i), 0, I387.soft.cwd);
  end;

procedure fmul__ ();
  var
    i: intg;
  begin
    (* fmul st,st(i) *)
    i := FPU_rm^;
    clear_C1();
    FPU_mul(st(i), FPU_gettagi(i), 0, I387.soft.cwd);
  end;

procedure fsub__ ();
  begin
    (* fsub st,st(i) *)
    clear_C1();
    FPU_sub(0, PFPU_REG(bx_ptr_equiv_t(FPU_rm)), I387.soft.cwd);
  end;

procedure fsubr_ ();
  begin
    (* fsubr st,st(i) *)
    clear_C1();
    FPU_sub(REV, PFPU_REG(bx_ptr_equiv_t(FPU_rm)), I387.soft.cwd);
  end;


procedure fdiv__ ();
  begin
    (* fdiv st,st(i) *)
    clear_C1();
    FPU_div(0, PFPU_REG(bx_ptr_equiv_t(FPU_rm)), I387.soft.cwd);
  end;


procedure fdivr_ ();
  begin
    (* fdivr st,st(i) *)
    clear_C1();
    FPU_div(REV, PFPU_REG(bx_ptr_equiv_t(FPU_rm)), I387.soft.cwd);
  end;

procedure fadd_i ();
  var
    i: intg;
  begin
    (* fadd st(i),st *)
    i := FPU_rm^;
    clear_C1();
    FPU_add(st(i), FPU_gettagi(i), i, I387.soft.cwd);
  end;


procedure fmul_i ();
  begin
    (* fmul st(i),st *)
    clear_C1();
    FPU_mul(st(0), FPU_gettag0(), FPU_rm^, I387.soft.cwd);
  end;


procedure fsubri ();
  begin
    (* fsubr st(i),st *)
    clear_C1();
    FPU_sub(DEST_RM, PFPU_REG(bx_ptr_equiv_t(FPU_rm)), I387.soft.cwd);
  end;


procedure fsub_i ();
  begin
    (* fsub st(i),st *)
    clear_C1();
    FPU_sub(REV or DEST_RM, PFPU_REG(bx_ptr_equiv_t(FPU_rm)), I387.soft.cwd);
  end;


procedure fdivri ();
  begin
    (* fdivr st(i),st *)
    clear_C1();
    FPU_div(DEST_RM, PFPU_REG(FPU_rm^), I387.soft.cwd);
  end;


procedure fdiv_i ();
  begin
    (* fdiv st(i),st *)
    clear_C1();
    FPU_div(REV or DEST_RM, PFPU_REG(FPU_rm^), I387.soft.cwd);
  end;

procedure faddp_ ();
  var
    i: intg;
  begin
    (* faddp st(i),st *)
    i := FPU_rm^;
    clear_C1();
    if (FPU_add(st(i), FPU_gettagi(i), i, I387.soft.cwd) >= 0) then
      FPU_pop();
  end;


procedure fmulp_ ();
  begin
    (* fmulp st(i),st *)
    clear_C1();
    if (FPU_mul(st(0), FPU_gettag0(), FPU_rm^, I387.soft.cwd) >= 0) then
      FPU_pop();
  end;


procedure fsubrp ();
  begin
    (* fsubrp st(i),st *)
    clear_C1();
    if (FPU_sub(DEST_RM, PFPU_REG(i387.soft.rm), I387.soft.cwd) >= 0) then
      FPU_pop();
  end;


procedure fsubp_ ();
  begin
    (* fsubp st(i),st *)
    clear_C1();
    if (FPU_sub(REV or DEST_RM, PFPU_REG(bx_ptr_equiv_t(FPU_rm)),
      I387.soft.cwd) >= 0) then
      FPU_pop();
  end;


procedure fdivrp ();
  begin
    (* fdivrp st(i),st *)
    clear_C1();
    if (FPU_div(DEST_RM, PFPU_REG(bx_ptr_equiv_t(FPU_rm)), I387.soft.cwd) >= 0) then
      FPU_pop();
  end;


procedure fdivp_ ();
  begin
    (* fdivp st(i),st *)
    clear_C1();
    if (FPU_div(REV or DEST_RM, PFPU_REG(bx_ptr_equiv_t(FPU_rm)),
      I387.soft.cwd) >= 0) then
      FPU_pop();
  end;

procedure FPU_pop;
  begin
    I387.soft.twd := I387.soft.twd or 3 shl ((I387.soft.ftop and 7) * 2);
    Inc(I387.soft.ftop);
  end;

function NOT_EMPTY (stnr: intg): intg;
  begin
    Result := word(FPU_empty_i(stnr) = 0);
  end;

function FPU_empty_i (stnr: intg): intg;
  var
    regnr: intg;
  begin
    regnr := (I387.soft.ftop + stnr) and 7;

    Result := word(((I387.soft.twd shr (regnr * 2)) and 3) = TAG_Empty);
  end;

end.
