unit reg_constant;

interface

uses fpu_types;

const
  CONST_1: FPU_REG = (sigl: $00000000; sigh: $80000000; exp: (($3fff + (0))));

const
  CONST_2: FPU_REG = (sigl: $00000000; sigh: $80000000; exp: ($3fff + (1)));

const
  CONST_HALF: FPU_REG = (sigl: $00000000; sigh: $80000000; exp: ($3fff + (-1)));

const
  CONST_L2T: FPU_REG = (sigl: $cd1b8afe; sigh: $d49a784b; exp: ($3fff + (1)));

const
  CONST_L2E: FPU_REG = (sigl: $5c17f0bc; sigh: $b8aa3b29; exp: ($3fff + (0)));

const
  CONST_PI: FPU_REG = (sigl: $2168c235; sigh: $c90fdaa2; exp: ($3fff + (1)));


  CONST_PI2: FPU_REG = (sigl: $c90fdaa2; sigh: $2168c235; exp: ($3fff + (0)));

const
  CONST_PI4: FPU_REG = (sigl: $c90fdaa2; sigh: $2168c235; exp: ($3fff + (-1)));

const
  CONST_LG2: FPU_REG = (sigl: $9a209a84; sigh: $fbcff799; exp: ($3fff + (-2)));

const
  CONST_LN2: FPU_REG = (sigl: $b17217f7; sigh: $d1cf79ac; exp: ($3fff + (-1)));

const
  CONST_PI2extra: FPU_REG = (sigl: $ece675d1; sigh: $fc8f8cbb; exp: ($3fff + (-66)));

const
  CONST_Z: FPU_REG = (sigl: $0; sigh: $0; exp: (($3fff + (-$3fff))));

const
  CONST_QNaN: FPU_REG = (sigl: $c0000000; sigh: $00000000; exp: ($3fff + ($4000)));


const
  CONST_INF: FPU_REG = (sigl: $8000; sigh: $00000000; exp: (($3fff + ($4000))));

procedure fconst;

implementation

uses fpu_tags, errors, fpu_system, Service_fpu, Math;

procedure fld_const (c: PFPU_REG; adj: intg; tag: u_char);
  var
    st_new_ptr: PFPU_REG;
  begin

    if (FPU_stackoverflow(st_new_ptr)) <> 0 then
      begin
      FPU_stack_overflow();
      exit;
      end;
    Dec(I387.soft.ftop);
    reg_copy(c, st_new_ptr); // zzzzzzzzz
    st_new_ptr^.sigl := st_new_ptr^.sigl + adj;  (* For all our fldxxx constants, we don't need to
             borrow or carry. *)
    FPU_settag0(tag);
    clear_C1();
  end;

(* A fast way to find out whether x is one of RC_DOWN or RC_CHOP
   (and not one of RC_RND or RC_UP).
   *)
procedure fld1 (rc: intg);
  begin
    fld_const(@CONST_1, 0, TAG_Valid);
  end;

procedure fldl2t (rc: intg);
  begin
    fld_const(@CONST_L2T, ifthen(rc = RC_UP, 1, 0), TAG_Valid);
  end;

procedure fldl2e (rc: intg);
  begin
    fld_const(@CONST_L2E, ifthen(rc and RC_DOWN <> 0, -1, 0), TAG_Valid);
  end;

procedure fldpi (rc: intg);
  begin
    fld_const(@CONST_PI, ifthen(rc and RC_DOWN <> 0, -1, 0), TAG_Valid);
  end;

procedure fldlg2 (rc: intg);
  begin
    fld_const(@CONST_LG2, ifthen(rc and RC_DOWN <> 0, -1, 0), TAG_Valid);
  end;

procedure fldln2 (rc: intg);
  begin
    fld_const(@CONST_LN2, ifthen(rc and RC_DOWN <> 0, -1, 0), TAG_Valid);
  end;

procedure fldz (rc: intg);
  begin
    fld_const(@CONST_Z, 0, TAG_Zero);
  end;

type
  FUNC_RC = procedure (i: intg);

procedure FPU_illegal (i: intg);
  begin
  end;

const
  constants_table: array[0..7] of FUNC_RC = (
    fld1, fldl2t, fldl2e, fldpi, fldlg2, fldln2, fldz, FPU_illegal);

procedure fconst;
  var
    P: FUNC_RC;
  begin
    P := constants_table[FPU_rm^];
    P(I387.soft.cwd and CW_RC);
  end;

end.
