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

interface

uses fpu_types;

const DOUBLE_Emax = 1023;         (* largest valid exponent *)
const DOUBLE_Ebias = 1023;
const DOUBLE_Emin = (-1022);      (* smallest valid exponent *)

const SINGLE_Emax = 127;          (* largest valid exponent *)
const SINGLE_Ebias = 127;
const SINGLE_Emin = (-126);       (* smallest valid exponent *)

function FPU_load_single(single:pfloat; loaded_data:PFPU_REG):intg;
function FPU_round_to_int(r:PFPU_REG; tag:u_char):intg;
function FPU_load_int32(_s:ps32; loaded_data:PFPU_REG):intg;
function FPU_load_double(dfloat:pdouble; loaded_data:PFPU_REG):intg;
function FPU_load_int16(_s:ps16; loaded_data:PFPU_REG):intg;
function FPU_store_single(st0_ptr:PFPU_REG; st0_tag:u_char; single:psingle):intg;
function FPU_store_int32(st0_ptr:PFPU_REG; st0_tag:u_char; d:ps32):intg;
function FPU_store_double(st0_ptr:PFPU_REG; st0_tag:u_char; dfloat:pdouble):intg;
function FPU_store_int16(st0_ptr:PFPU_REG; st0_tag:u_char; d:ps16):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 FPU_load_bcd(s:pu_char):intg;
function FPU_load_extended(s:extended; stnr:intg):intg;
function FPU_load_int64(_s:ps64):intg;
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_store_bcd(st0_ptr:PFPU_REG; st0_tag:u_char; d:u_char):intg;
function FPU_store_extended(st0_ptr:PFPU_REG; st0_tag:u_char; d:pextended):intg;
function FPU_store_int64(st0_ptr:PFPU_REG; st0_tag:u_char; d:s64):intg;

implementation

uses Service_fpu, fpu_system, wmfpuemu_Glue, Math, errors, cpu, fpu_tags,
  reg_aux;

function normalize_no_excep(r:PFPU_REG; exp:intg; sign:intg):u_char;
var
  tag:u_char;
begin

  setexponent16(r, exp);

  tag := FPU_normalize_nuo(r, 0);
  stdexp(r);
  if ( sign )<>0 then
    setnegative(r);

  result := tag;
end;


function FPU_tagof(ptr:PFPU_REG):intg;
var
  exp:intg;
begin

  exp := exponent16(ptr)  and $7fff;
  if ( exp = 0 ) then
    begin
      if ( (ptr^.sigh or ptr^.sigl) )=0 then
	begin
	  Result:= TAG_Zero;
     Exit;
	end;
      (* The number is a de-normal or pseudodenormal. *)
      Result := TAG_Special;
      Exit;
    end;

  if ( exp = $7fff ) then
    begin
      (* Is an Infinity, a NaN, or an unsupported data type. *)
      Result := TAG_Special;
      Exit;
    end;

  if ( (ptr^.sigh  and $80000000)=0 ) then
    begin
      (* Unsupported data type. *)
      (* Valid numbers have the ms bit set to 1. *)
      (* Unnormal. *)
      Result := TAG_Special;
      Exit;
    end;

    Result := TAG_Valid;
    Exit;
end;


(* Get a long double from user memory *)
function FPU_load_extended(s:extended; stnr:intg):intg;
var
   sti_ptr:PFPU_REG;
begin
  sti_ptr := st(stnr);

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_READ, @s, 10);
{$ifndef USE_WITH_CPU_SIM}
  __copy_from_user(sti_ptr, s, 10);
{$else}
  //FPU_get_user(sti_ptr^.sigl, (u32*)(((u8*)s)+0)); !!!
  //FPU_get_user(sti_ptr^.sigh, (u32*)(((u8*)s)+4)); !!!
  //FPU_get_user(sti_ptr^.exp,  (u16*)(((u8*)s)+8)); !!!
{$endif}
  //RE_ENTRANT_CHECK_ON;

  Result:= FPU_tagof(sti_ptr);
end;


(* Get a double from user memory *)
function FPU_load_double(dfloat:pdouble; loaded_data:PFPU_REG):intg;
var
  exp, tag, negative:intg;
  m64, l64:u32;
begin

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_READ, dfloat, 8);
  m64:=FPU_get_user(Pointer(Sizeof(Single) + LongWord(dfloat)),Sizeof(Single));
  l64:=FPU_get_user(dfloat,Sizeof(Single));
  //RE_ENTRANT_CHECK_ON;

  negative := ifthen((m64 and $80000000)<>0,SIGN_Negative,SIGN_Positive);
  exp := ((m64 and $7ff00000) shr 20) - DOUBLE_Ebias + EXTENDED_Ebias;
  m64 := m64 and $fffff;
  if ( exp > DOUBLE_Emax + EXTENDED_Ebias ) then
    begin
      (* Infinity or NaN *)
      if ((m64 = 0) and (l64 = 0)) then
	begin
	  (* +- infinity *)
	  loaded_data^.sigh := $80000000;
	  loaded_data^.sigl := $00000000;
	  exp := EXP_Infinity + EXTENDED_Ebias;
	  tag := TAG_Special;
	end
      else
	begin
	  (* Must be a signaling or quiet NaN *)
	  exp := EXP_NaN + EXTENDED_Ebias;
	  loaded_data^.sigh := (m64 shl 11)or$80000000;
	  loaded_data^.sigh :=	  loaded_data^.sigh or l64 shr 21;
	  loaded_data^.sigl := l64 shl 11;
	  tag := TAG_Special;    (* The calling function must look for NaNs *)
	end;
    end
  else if ( exp < DOUBLE_Emin + EXTENDED_Ebias ) then
    begin
      (* Zero or de-normal *)
      if ((m64 = 0) and (l64 = 0)) then
	begin
	  (* Zero *)
	  reg_copy(@CONST_Z, loaded_data);
	  exp := 0;
	  tag := TAG_Zero;
	end
      else
	begin
	  (* De-normal *)
	  loaded_data^.sigh := m64 shl 11;
	  loaded_data^.sigh :=	  loaded_data^.sigh or l64 shr 21;
	  loaded_data^.sigl := l64 shl 11;

	  Result:= normalize_no_excep(loaded_data, DOUBLE_Emin, negative)
	   or (ifthen(denormal_operand() < 0 , FPU_Exception_c , 0));
	end;
    end
  else
    begin
      loaded_data^.sigh := (m64 shl 11)or$80000000;
      loaded_data^.sigh :=      loaded_data^.sigh or l64 shr 21;
      loaded_data^.sigl := l64 shl 11;

      tag := TAG_Valid;
    end;

  setexponent16(loaded_data, exp or negative);

  Result:= tag;
end;


(* Get a float from user memory *)
function FPU_load_single(single:pfloat; loaded_data:PFPU_REG):intg;
var
  m32:u32;
  exp, tag, negative:intg;
begin

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_READ, @single, 4);
  m32:=FPU_get_user(single, sizeof(single^));
  //RE_ENTRANT_CHECK_ON;

  negative := ifthen((m32  and $80000000)<>0,SIGN_Negative, SIGN_Positive);

  if ((m32 and $7fffffff)=0) then
    begin
      (* Zero *)
      reg_copy(@CONST_Z, loaded_data);
      addexponent(loaded_data, negative);
      Result := TAG_Zero;
      Exit;
    end;
  exp := ((m32  and $7f800000) shr 23) - SINGLE_Ebias + EXTENDED_Ebias;
  m32 := (m32  and $7fffff) shl 8;
  if ( exp < SINGLE_Emin + EXTENDED_Ebias ) then
    begin
      (* De-normals *)
      loaded_data^.sigh := m32;
      loaded_data^.sigl := 0;

      Result:= normalize_no_excep(loaded_data, SINGLE_Emin, negative) or
   	ifthen(denormal_operand() < 0 , FPU_Exception_c , 0);
    end
  else if ( exp > SINGLE_Emax + EXTENDED_Ebias ) then
    begin
    (* Infinity or NaN *)
      if ( m32 = 0 ) then
	begin
	  (* +- infinity *)
	  loaded_data^.sigh := $80000000;
	  loaded_data^.sigl := $00000000;
	  exp := EXP_Infinity + EXTENDED_Ebias;
	  tag := TAG_Special;
	end
      else
	begin
	  (* Must be a signaling or quiet NaN *)
	  exp := EXP_NaN + EXTENDED_Ebias;
	  loaded_data^.sigh := m32 or $80000000;
	  loaded_data^.sigl := 0;
	  tag := TAG_Special;  (* The calling function must look for NaNs *)
	end;
    end
  else
    begin
      loaded_data^.sigh := m32 or $80000000;
      loaded_data^.sigl := 0;
      tag := TAG_Valid;
    end;

  setexponent16(loaded_data, exp or negative);  (* Set the sign. *)

  Result:= tag;
end;


(* Get a 64bit quantity from user memory *)
function FPU_load_int64(_s:ps64):intg;
var
  s:s64;
  sign:intg;
  st0_ptr:PFPU_REG;
  chunk0, chunk1:u32;
begin
  st0_ptr:= st(0);
  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_READ, @_s, 8);
{$ifndef USE_WITH_CPU_SIM}
  copy_from_user(@s,_s,8);
{$else}
  begin
  chunk0:=FPU_get_user(PLongWord(PByte(_s)),1);
  chunk1:=FPU_get_user((PByte(LongWord(_s)+4)),1);
  s := chunk0;
  s :=  s or ((u64(chunk1) shl 32));
  end;
{$endif}
  //RE_ENTRANT_CHECK_ON;

  if (s = 0) then
    begin
      reg_copy(@CONST_Z, st0_ptr);
      Result := TAG_Zero;
      Exit;
    end;

  if (s > 0) then
    sign := SIGN_Positive
  else
  begin
    s := -s;
    sign := SIGN_Negative;
  end;

  st0_ptr^.sigh := s;

  Result:= normalize_no_excep(st0_ptr, 63, sign);
end;


(* Get a long from user memory *)
function FPU_load_int32(_s:ps32; loaded_data:PFPU_REG):intg;
var
  s:s32;
  negative:intg;
begin

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_READ, _s, 4);
  s:=FPU_get_user(_s, sizeof(_s^));
  //RE_ENTRANT_CHECK_ON;

  if (s = 0) then
    begin
      reg_copy(@CONST_Z, loaded_data);
      Result:= TAG_Zero;
      Exit;
    end;

  if (s > 0) then
    negative := SIGN_Positive
  else
    begin
      s := -s;
      negative := SIGN_Negative;
    end;

  loaded_data^.sigh := s;
  loaded_data^.sigl := 0;

  Result := normalize_no_excep(loaded_data, 31, negative);
end;


(* Get a short from user memory *)
function FPU_load_int16(_s:ps16; loaded_data:PFPU_REG):intg;
var
  s, negative:intg;
begin

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_READ, _s, 2);
  (* Cast as short to get the sign extended. *)
  FPU_get_user(@s, _s^);
  //RE_ENTRANT_CHECK_ON;

  if (s = 0) then
    begin
      reg_copy(@CONST_Z, loaded_data);
      Result:= TAG_Zero;
      Exit;
    end;

  if (s > 0) then
    negative := SIGN_Positive
  else
    begin
      s := -s;
      negative := SIGN_Negative;
    end;

  loaded_data^.sigh := s shl 16;
  loaded_data^.sigl := 0;

  Result:= normalize_no_excep(loaded_data, 15, negative);
end;


(* Get a packed bcd array from user memory *)
function FPU_load_bcd(s:pu_char):intg;
var
  st0_ptr:PFPU_REG;
  pos:intg;
  bcd:u_char;
  l:s64;
  sign:intg;
begin
  st0_ptr := st(0);
  l:=0;

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_READ, s, 10);
  //RE_ENTRANT_CHECK_ON;
  pos:=8;
  while pos >= 0 do
    begin
      l := l * 10;
      //RE_ENTRANT_CHECK_OFF;
      FPU_get_user(@bcd, u_char(s)+pos);
      //RE_ENTRANT_CHECK_ON;
      l :=      l + bcd shr 4;
      l := l * 10;
      l :=      l + bcd  and $0f;
      dec(pos);
    end;
 
  //RE_ENTRANT_CHECK_OFF;
  FPU_get_user(@sign, u_char(s)+9);
  sign := ifthen((sign and $80)<>0,SIGN_Negative,SIGN_Positive);
  //RE_ENTRANT_CHECK_ON;

  if ( l = 0 ) then
    begin
      reg_copy(@CONST_Z, st0_ptr);
      addexponent(st0_ptr, sign);   (* Set the sign. *)
      Result:= TAG_Zero;
      Exit;
    end
  else
    begin
      st0_ptr^.sigh := l;
      Result:= normalize_no_excep(st0_ptr, 63, sign);
      Exit;
    end;
end;

(*=====================================:=*)

(* Put a long double into user memory *)
function FPU_store_extended(st0_ptr:PFPU_REG; st0_tag:u_char; d:pextended):intg;
begin
  (*
    The only exception raised by an attempt to store to an
    extended format is the Invalid Stack exception, i.e.
    attempting to store from an empty register.
   *)

  if ( st0_tag <> TAG_Empty ) then
    begin
      //RE_ENTRANT_CHECK_OFF;
      FPU_verify_area(VERIFY_WRITE, d, 10);

      FPU_put_user(st0_ptr^.sigl, pu32(d), sizeof(pu32(d)^));
      FPU_put_user(st0_ptr^.sigh, pu32(LongInt(d)+4),sizeof(pu32(d)^));//!!! vedere codice originale per i cast
      FPU_put_user(exponent16(st0_ptr), pu16(LongInt(d)+8),sizeof(pu16(d)^));
      //RE_ENTRANT_CHECK_ON;

      Result:=1;
      Exit;
    end;

  (* Empty register (stack underflow) *)
  fpu_EXCEPTION(EX_StackUnder);
  if ( I387.soft.cwd  and CW_Invalid )<>0 then
    begin
      (* The masked response *)
      (* Put out the QNaN indefinite *)
      //RE_ENTRANT_CHECK_OFF;
      FPU_verify_area(VERIFY_WRITE,d,10);
      FPU_put_user(0, pu32(d),sizeof(pu32(d)^));
      FPU_put_user($c0000000, pu32(longint(d)+1),sizeof(pu32(d)^));
      FPU_put_user($ffff, ps16(longint(d)+4),sizeof(ps16(d)^));
      //RE_ENTRANT_CHECK_ON;
      Result:=1;
      Exit;
    end
  else
   begin
      Result:=0;
      Exit;
   end;

end;


(* Put a double into user memory *)
function FPU_store_double(st0_ptr:PFPU_REG; st0_tag:u_char; dfloat:pdouble):intg;
var
  l:array[0..2] of u32;
  increment :u32;	(* aprocedure gcc warnings *)
  precision_loss:intg;
  exp:intg;
  tmp:FPU_REG;

  label denormal_arg,overflow;
begin
  increment := 0;	(* aprocedure gcc warnings *)

  if ( st0_tag = TAG_Valid ) then
    begin
      reg_copy(@st0_ptr, @tmp);
      exp := exponent(@tmp);

      if ( exp < DOUBLE_Emin ) then     (* It may be a denormal *)
	begin
	  addexponent(@tmp, -DOUBLE_Emin + 52);  (* largest exp to be 51 *)

	denormal_arg:
   precision_loss := FPU_round_to_int(@tmp, st0_tag);

	  if ( precision_loss<>0 ) then
	    begin
{$ifdef PECULIAR_486}
	      (* Did it round to a non-denormal ? *)
	      (* This behaviour might be regarded as peculiar, it appears
		 that the 80486 rounds to the dest precision, then
		 converts to decide underflow. *)
	      if ( ((tmp.sigh = $00100000) and (tmp.sigl = 0) and ((st0_ptr^.sigl and $000007ff)<>0) ))=false then
{$endif} (* PECULIAR_486 *)
		begin
		  fpu_EXCEPTION(EX_Underflow);
		  (* This is a special case: see sec 16.2.5.1 of
		     the 80486 book *)
		  if ( (I387.soft.cwd  and CW_Underflow)=0 ) then
         begin
		    Result:= 0;
          Exit;
         end;
		end;
	      fpu_EXCEPTION(precision_loss);
	      if ( (I387.soft.cwd  and CW_Precision)=0 ) then
            begin
         		Result:= 0;
               Exit;
            end;
	    end;
	  l[0] := tmp.sigl;
	  l[1] := tmp.sigh;
	end
      else
	begin
	  if ( tmp.sigl  and $000007ff )<>0 then
	    begin
	      precision_loss := 1;
	      case (I387.soft.cwd  and CW_RC) of
		RC_RND:
         begin
		  (* Rounding can get a little messy.. *)
		  increment := Word((tmp.sigl  and $7ff) > $400)or (* nearest *)
		    Word((tmp.sigl  and $c00) = $c00);            (* odd ^. even *)
		  end;
		RC_DOWN:   (* towards -infinity *)
         begin
   		  increment := ifthen(signpositive(@tmp)<>0, 0 , tmp.sigl  and $7ff);
		   end;
		RC_UP:     (* towards +infinity *)
         begin
   		  increment := ifthen(signpositive(@tmp)<>0, tmp.sigl  and $7ff , 0);
		   end;
		RC_CHOP:
         begin
   		  increment := 0;
		   end;
		end;

	      (* Truncate the mantissa *)
	      tmp.sigl := tmp.sigl and $fffff800;

	      if ( increment )<>0 then
		begin
		  if ( tmp.sigl >= $fffff800 ) then
		    begin
		      (* the sigl part overflows *)
		      if ( tmp.sigh = $ffffffff ) then
			begin
			  (* The sigh part overflows *)
			  tmp.sigh := $80000000;
			  inc(exp);
			  if (exp >= EXP_OVER) then
			    goto overflow;
			end
		      else
			begin
			  inc(tmp.sigh);
			end;
		      tmp.sigl := $00000000;
		    end
		  else
		    begin
		      (* We only need to increment sigl *)
		      tmp.sigl :=		      tmp.sigl + $00000800;
		    end;
		end;
	    end
	  else
	    precision_loss := 0;
	  
	  l[0] := (tmp.sigl shr 11)or(tmp.sigh shl 21);
	  l[1] := ((tmp.sigh shr 11)  and $fffff);

	  if ( exp > DOUBLE_Emax ) then
	    begin
	    overflow:
	      fpu_EXCEPTION(EX_Overflow);
	      if ( (I387.soft.cwd  and CW_Overflow)=0 ) then
            begin
		         Result:=0;
               Exit;
            end;
	      set_precision_flag_up();
	      if ( (I387.soft.cwd  and CW_Precision)=0 ) then
            begin
		         Result:=1;
               Exit;
            end;
         Result:=0;
         Exit;

	      (* This is a special case: see sec 16.2.5.1 of the 80486 book *)
	      (* Overflow to infinity *)
	      l[0] := $00000000;	(* Set to *)
	      l[1] := $7ff00000;	(* + INF *)
	    end
	  else
	    begin
	      if ( precision_loss )<>0 then
		begin
		  if ( increment )<>0 then
		    set_precision_flag_up()
		  else
		    set_precision_flag_down();
		end;
	      (* Add the exponent *)
	      l[1] := l[1] or (((exp+DOUBLE_Ebias)  and $7ff) shl 20);
	    end;
	end;
    end
  else if (st0_tag = TAG_Zero) then
    begin
      (* Number is zero *)
      l[0] := 0;
      l[1] := 0;
    end
  else if ( st0_tag = TAG_Special ) then
    begin
      st0_tag := FPU_Special(st0_ptr);
      if ( st0_tag = TW_Denormal ) then
	begin
	  (* A denormal will always underflow. *)
{$ifndef PECULIAR_486}
	  (* An 80486 is supposed to be able to generate
	     a denormal exception here, but... *)
	  (* Underflow has priority. *)
	  if ( I387.soft.cwd  and CW_Underflow )<>0 then
	    denormal_operand();
{$endif} (* PECULIAR_486 *)
	  reg_copy(st0_ptr, @tmp);
	  goto denormal_arg;
	end
      else if (st0_tag = TW_Infinity) then
	begin
	  l[0] := 0;
	  l[1] := $7ff00000;
	end
      else if (st0_tag = TW_NaN) then
	begin
	  (* Is it really a NaN ? *)
	  if ( (exponent(st0_ptr) = EXP_OVER) and ((st0_ptr^.sigh  and $80000000)<>0) ) then
	    begin
	      (* See if we can get a valid NaN from the FPU_REG *)
	      l[0] := (st0_ptr^.sigl shr 11)or(st0_ptr^.sigh shl 21);
	      l[1] := ((st0_ptr^.sigh shr 11)  and $fffff);
	      if ( (st0_ptr^.sigh  and $40000000)=0 ) then
		begin
		  (* It is a signalling NaN *)
		  fpu_EXCEPTION(EX_Invalid);
		  if ( (I387.soft.cwd  and CW_Invalid)=0 ) then
          begin
		      Result:= 0;
            Exit;
          end;
		  l[1] :=  l[1] or ($40000000 shr 11);
		end;
	      l[1] := l[1] or $7ff00000;
	    end
	  else
	    begin
	      (* It is an unsupported data type *)
	      fpu_EXCEPTION(EX_Invalid);
	      if ( (I387.soft.cwd  and CW_Invalid)=0 ) then
          begin
		      Result:= 0;
            Exit;
          end;
	      l[0] := 0;
	      l[1] := $fff80000;
	    end;
	end;
    end
  else if ( st0_tag = TAG_Empty ) then
    begin
      (* Empty register (stack underflow) *)
      fpu_EXCEPTION(EX_StackUnder);
      if ( I387.soft.cwd  and CW_Invalid )<>0 then
	begin
	  (* The masked response *)
	  (* Put out the QNaN indefinite *)
	  //RE_ENTRANT_CHECK_OFF;
	  FPU_verify_area(VERIFY_WRITE,dfloat,8);
	  FPU_put_user(0, pu32(dfloat),sizeof(pu32(dfloat)^));
	  FPU_put_user($fff80000, pu32(longint(dfloat)+1),sizeof(pu32(dfloat)^));
	  //RE_ENTRANT_CHECK_ON;
	  Result:=1;
     Exit;
	end
      else
         begin
         	Result:=0;
            exit;
         end;
    end;
  if ( getsign(st0_ptr)<>0 ) then
    l[1] :=    l[1] or $80000000;

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_WRITE,dfloat,8);
  FPU_put_user(l[0], pu32(dfloat),sizeof(pu32(dfloat)^));
  FPU_put_user(l[1], pu32(longint(dfloat)+1),sizeof(pu32(dfloat)^));
  //RE_ENTRANT_CHECK_ON;

  Result:= 1;
end;


(* Put a float into user memory *)
function FPU_store_single(st0_ptr:PFPU_REG; st0_tag:u_char; single:psingle):intg;
var
  templ:s32;
  increment :u32;
  precision_loss:intg;
  exp:intg;
  tmp:FPU_REG;
  sigh:u32;
  sigl:u32;

  label denormal_arg,overflow;
begin
  increment := 0;     	(* aprocedure gcc warnings *)

  if ( st0_tag = TAG_Valid ) then
    begin

      reg_copy(st0_ptr, @tmp);
      exp := exponent(@tmp);

      if ( exp < SINGLE_Emin ) then
	begin
	  addexponent(@tmp, -SINGLE_Emin + 23);  (* largest exp to be 22 *)

	denormal_arg:
     precision_loss := FPU_round_to_int(@tmp, st0_tag);
	  if ( precision_loss<>0 ) then
	    begin
{$ifdef PECULIAR_486}
	      (* Did it round to a non-denormal ? *)
	      (* This behaviour might be regarded as peculiar, it appears
		 that the 80486 rounds to the dest precision, then
		 converts to decide underflow. *)
	      if ( (tmp.sigl = $00800000) and  (((st0_ptr^.sigh and $000000ff) or st0_ptr^.sigl)<>0) )=false then
{$endif} (* PECULIAR_486 *)
		begin
		  fpu_EXCEPTION(EX_Underflow);
		  (* This is a special case: see sec 16.2.5.1 of
		     the 80486 book *)
		  if ( (I387.soft.cwd  and CW_Underflow)=0 ) then
          begin
		      Result:= 0;
            exit;
          end
		end;
	      fpu_EXCEPTION(precision_loss);
	      if ( (I387.soft.cwd  and CW_Precision)=0 ) then
            begin
   		      Result:= 0;
               exit;
            end;
	    end;
	  templ := tmp.sigl;
      end
      else
	begin
	  if ( tmp.sigl or (tmp.sigh  and $000000ff) )<>0 then
	    begin
	      sigh := tmp.sigh;
	      sigl := tmp.sigl;
	      
	      precision_loss := 1;
	      case (I387.soft.cwd  and CW_RC) of
    		RC_RND:
           begin
   		       increment := word((sigh  and $ff) > $80)       (* more than half *)
                       or word(((sigh  and $ff) = $80) and (sigl<>0))   (* more than half *)
             		       or word((sigh  and $180) = $180);        (* round to even *)
		   end;
		RC_DOWN:   (* towards -infinity *)
         begin
		  increment := ifthen(signpositive(@tmp)<>0, 0 , word(sigl or (sigh  and $ff)));
		  end;
		RC_UP:     (* towards +infinity *)
         begin
		  increment := ifthen(signpositive(@tmp)<>0,(sigl or(sigh  and $ff)), 0);
 		   end;
		RC_CHOP:
         begin
   		  increment := 0;
		   end;
		end;
	  
	      (* Truncate part of the mantissa *)
	      tmp.sigl := 0;
	  
	      if (increment)<>0 then
      		begin
		        if ( sigh >= $ffffff00 ) then
      		    begin
      		      (* The sigh part overflows *)
		            tmp.sigh := $80000000;
		            inc(exp);
         	      if ( exp >= EXP_OVER ) then
			            goto overflow;
         	    end
     		   else
   		    begin
		      tmp.sigh := tmp.sigh and $ffffff00;
		      tmp.sigh :=	tmp.sigh + $100;
		    end;
		end
	      else
		begin
		  tmp.sigh := tmp.sigh and $ffffff00;  (* Finish the truncation *)
		end;
	    end
	  else
	    precision_loss := 0;
      
	  templ := (tmp.sigh shr 8)  and $007fffff;

	  if ( exp > SINGLE_Emax ) then
	    begin
	    overflow:
	      fpu_EXCEPTION(EX_Overflow);
	      if ( (I387.soft.cwd  and CW_Overflow)=0 ) then
            begin
      		   Result:= 0;
               Exit;
            end;
	      set_precision_flag_up();
	      if ( (I387.soft.cwd  and CW_Precision)=0 ) then
            begin
      		   Result:= 0;
               Exit;
            end;

	      (* This is a special case: see sec 16.2.5.1 of the 80486 book. *)
	      (* Masked response is overflow to infinity. *)
	      templ := $7f800000;
	    end
	  else
	    begin
	      if ( precision_loss )<>0 then
		begin
		  if ( increment )<>0 then
		    set_precision_flag_up()
		  else
		    set_precision_flag_down();
		end;
	      (* Add the exponent *)
	      templ :=	 templ or ((exp+SINGLE_Ebias)  and $ff) shl 23;
	    end;
	end;
    end
  else if (st0_tag = TAG_Zero) then
    begin
      templ := 0;
    end
  else if ( st0_tag = TAG_Special ) then
    begin
      st0_tag := FPU_Special(st0_ptr);
      if (st0_tag = TW_Denormal) then
	begin
	  reg_copy(st0_ptr, @tmp);

	  (* A denormal will always underflow. *)
{$ifndef PECULIAR_486}
	  (* An 80486 is supposed to be able to generate
	     a denormal exception here, but... *)
	  (* Underflow has priority. *)
	  if ( I387.soft.cwd  and CW_Underflow )
	    denormal_operand();
{$endif} (* PECULIAR_486 *)
	  goto denormal_arg;
	end
      else if (st0_tag = TW_Infinity) then
	begin
	  templ := $7f800000;
	end
      else if (st0_tag = TW_NaN) then
	begin
	  (* Is it really a NaN ? *)
	  if ( (exponent(st0_ptr) = EXP_OVER) and ((st0_ptr^.sigh  and $80000000)<>0) ) then
	    begin
	      (* See if we can get a valid NaN from the FPU_REG *)
	      templ := st0_ptr^.sigh shr 8;
	      if ( (st0_ptr^.sigh  and $40000000)=0 ) then
		begin
		  (* It is a signalling NaN *)
		  fpu_EXCEPTION(EX_Invalid);
		  if ( (I387.soft.cwd  and CW_Invalid)=0 ) then
         begin
		    Result := 0;
          exit;
         end;
		  templ :=		  templ or ($40000000 shr 8);
		end;
	      templ :=	      templ or $7f800000;
	    end
	  else
	    begin
	      (* It is an unsupported data type *)
	      fpu_EXCEPTION(EX_Invalid);
	      if ( (I387.soft.cwd  and CW_Invalid)=0 ) then
         begin
		    Result := 0;
          exit;
         end;
	      templ := $ffc00000;
	    end;
	end;
{$ifdef PARANOID}
      else
	begin
	  EXCEPTION(EX_INTERNAL|$164);
	  return 0;
	end;
{$endif}
    end
  else if ( st0_tag = TAG_Empty ) then
    begin
      (* Empty register (stack underflow) *)
      fpu_EXCEPTION(EX_StackUnder);
      if ( I387.soft.cwd  and EX_Invalid )<>0 then
	begin
	  (* The masked response *)
	  (* Put out the QNaN indefinite *)
	  //RE_ENTRANT_CHECK_OFF;
	  FPU_verify_area(VERIFY_WRITE,single,4);
	  FPU_put_user($ffc00000, pu32(single),sizeof(pu32(single)^));
	  //RE_ENTRANT_CHECK_ON;
	  Result := 1;
     Exit;
	end
      else
         begin
      	  Result := 1;
           Exit;
         end;
    end;
{$ifdef PARANOID}
  else
    begin
      EXCEPTION(EX_INTERNAL|$163);
      return 0;
    end;
{$endif}
  if ( getsign(st0_ptr) )<>0 then
    templ :=    templ or $80000000;

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_WRITE,single,4);
  FPU_put_user(templ,pu32(single),sizeof(pu32(single)^));
  //RE_ENTRANT_CHECK_ON;

  Result:= 1;
end;


(* Put a 64bit quantity into user memory *)
function FPU_store_int64(st0_ptr:PFPU_REG; st0_tag:u_char; d:s64):intg;
var
  t:FPU_REG;
  tll:s64;
  precision_loss:intg;

  label invalid_operand;
begin

  if ( st0_tag = TAG_Empty ) then
    begin
      (* Empty register (stack underflow) *)
      fpu_EXCEPTION(EX_StackUnder);
      goto invalid_operand;
    end
  else if ( st0_tag = TAG_Special ) then
    begin
      st0_tag := FPU_Special(st0_ptr);
      if ( (st0_tag = TW_Infinity) or (st0_tag = TW_NaN) ) then
      	begin
      	  fpu_EXCEPTION(EX_Invalid);
      	  goto invalid_operand;
      	end;
    end;

  reg_copy(st0_ptr, @t);
  precision_loss := FPU_round_to_int(@t, st0_tag);
{$ifndef EMU_BIG_ENDIAN}
  pu32(@tll)^ := t.sigl;
  pu32(longint(@tll)+1)^ := t.sigh;
  //((u32 *)@tll)[0] := t.sigl;
  //((u32 *)@tll)[1] := t.sigh;
{$else}
  pu32(@tll)^ := t.sigh;
  pu32(longint(@tll)+1)^ := t.sigl;
{$endif}
  if ( (precision_loss = 1) or (((t.sigh  and $80000000)<>0) and
       (((t.sigh = $80000000)=true) and (t.sigl = 0) and (signnegative(@t)<>0)) )) then
       begin
      fpu_EXCEPTION(EX_Invalid);
      (* This is a special case: see sec 16.2.5.1 of the 80486 book *)
       invalid_operand:
      if ( I387.soft.cwd  and EX_Invalid )<>0 then
      begin
	  (* Produce something like QNaN 'indefinite' *)
   	  tll := $8000000000000000;
	   end
      else
	   Result:= 0;
      Exit;
    end
  else
    begin
      if ( precision_loss )<>0 then
      	set_precision_flag(precision_loss);
      if ( signnegative(@t) )<>0 then
      	tll := - tll;
    end;

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_WRITE,@d,8);
{$ifndef USE_WITH_CPU_SIM}
  copy_to_user(d, @tll, 8);
{$else}
  FPU_put_user(u32(tll),  pu32(pu8(@d)),4);
  FPU_put_user(u32(tll shr 32), pu32(pu8(LongInt(@d)+4)),4);
{$endif}
  //RE_ENTRANT_CHECK_ON;

  Result:= 1;
end;


(* Put a long into user memory *)
function FPU_store_int32(st0_ptr:PFPU_REG; st0_tag:u_char; d:ps32):intg;
var
  t:FPU_REG;
  precision_loss:intg;
  label invalid_operand;
begin

  if ( st0_tag = TAG_Empty ) then
    begin
      (* Empty register (stack underflow) *)
      fpu_EXCEPTION(EX_StackUnder);
      goto invalid_operand;
    end
  else if ( st0_tag = TAG_Special ) then
    begin
      st0_tag := FPU_Special(st0_ptr);
      if ( (st0_tag = TW_Infinity) or (st0_tag = TW_NaN) ) then
	begin
	  fpu_EXCEPTION(EX_Invalid);
	  goto invalid_operand;
	end;
    end;

  reg_copy(st0_ptr, @t);
  precision_loss := FPU_round_to_int(@t, st0_tag);
  if ((t.sigh<>0) or (((t.sigl and $80000000)<>0) and
       ((t.sigl = $80000000) and (signnegative(@t)<>0))=false) ) then
    begin
      fpu_EXCEPTION(EX_Invalid);
      (* This is a special case: see sec 16.2.5.1 of the 80486 book *)
    invalid_operand:
      if ( I387.soft.cwd  and EX_Invalid )<>0 then
      	begin
      	  (* Produce something like QNaN 'indefinite' *)
      	  t.sigl := $80000000;
      	end
      else
         begin
         	Result:= 0;
            exit;
         end;
    end
  else
    begin
      if ( precision_loss )<>0 then
      	set_precision_flag(precision_loss);
      if ( signnegative(@t) )<>0 then
      	t.sigl := -s32(t.sigl);
    end;

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_WRITE,d,4);
  FPU_put_user(t.sigl, pu32(d),4);
  //RE_ENTRANT_CHECK_ON;

  Result:= 1;
end;


(* Put a short into user memory *)
function FPU_store_int16(st0_ptr:PFPU_REG; st0_tag:u_char; d:ps16):intg;
var
  t:FPU_REG;
  precision_loss:intg;

  label invalid_operand;
begin

  if ( st0_tag = TAG_Empty ) then
    begin
      (* Empty register (stack underflow) *)
      fpu_EXCEPTION(EX_StackUnder);
      goto invalid_operand;
    end
  else if ( st0_tag = TAG_Special ) then
    begin
      st0_tag := FPU_Special(st0_ptr);
      if ( (st0_tag = TW_Infinity) or (st0_tag = TW_NaN) ) then
	begin
	  fpu_EXCEPTION(EX_Invalid);
	  goto invalid_operand;
	end;
    end;

  reg_copy(st0_ptr, @t);
  precision_loss := FPU_round_to_int(@t, st0_tag);
  if (t.sigh<>0) or (((t.sigl and $ffff8000)<>0) and (signnegative(@t)<>0))=false then
    begin
      fpu_EXCEPTION(EX_Invalid);
      (* This is a special case: see sec 16.2.5.1 of the 80486 book *)
    invalid_operand:
      if ( I387.soft.cwd  and EX_Invalid )<>0 then
	begin
	  (* Produce something like QNaN 'indefinite' *)
	  t.sigl := $8000;
	end
      else
	result:= 0;
  exit;
    end
  else
    begin
      if ( precision_loss )<>0 then
	set_precision_flag(precision_loss);
      if ( signnegative(@t)<>0 ) then
	t.sigl := -t.sigl;
    end;

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_WRITE,d,2);
  FPU_put_user(s16(t.sigl),ps16(d),sizeof(s16));
  //RE_ENTRANT_CHECK_ON;

  Result:= 1;
end;


(* Put a packed bcd array into user memory *)
function FPU_store_bcd(st0_ptr:PFPU_REG; st0_tag:u_char; d:u_char):intg;
var
  t:FPU_REG;
  ll:u64;
  b:u_char;
  i, precision_loss:intg;
  sign:u_char;
  label invalid_operand;
begin
  sign:=ifthen(getsign(st0_ptr) = SIGN_NEG , $80 , 0);
  if ( st0_tag = TAG_Empty ) then
    begin
      (* Empty register (stack underflow) *)
      fpu_EXCEPTION(EX_StackUnder);
      goto invalid_operand;
    end
  else if ( st0_tag = TAG_Special ) then
    begin
      st0_tag := FPU_Special(st0_ptr);
      if ( (st0_tag = TW_Infinity) or (st0_tag = TW_NaN) ) then
	begin
	  fpu_EXCEPTION(EX_Invalid);
	  goto invalid_operand;
	end;
    end;

  reg_copy(st0_ptr, @t);
  precision_loss := FPU_round_to_int(@t, st0_tag);
  ll := significand(@t)^;

  (* Check for overflow, by comparing with 999999999999999999 decimal. *)
  if ( (t.sigh > $0de0b6b3) or
      ((t.sigh = $0de0b6b3) and (t.sigl > $a763ffff)) ) then
    begin
      fpu_EXCEPTION(EX_Invalid);
      (* This is a special case: see sec 16.2.5.1 of the 80486 book *)
    invalid_operand:
      if ( I387.soft.cwd  and CW_Invalid )<>0 then
	begin
	  (* Produce the QNaN 'indefinite' *)
	  //RE_ENTRANT_CHECK_OFF;
	  FPU_verify_area(VERIFY_WRITE,@d,10);
    i:=0;
	  while i < 7 do
      begin
  	    FPU_put_user(0, pu_char(longint(@d)+i),sizeof(d)); (* These bytes 'undefined' *)
        inc(i);
      end;
	  FPU_put_user($c0, pu_char(longint(d)+7),sizeof(d)); (* This byte 'undefined' *)
	  FPU_put_user($ff, pu_char(longint(d)+8),sizeof(d));
	  FPU_put_user($ff, pu_char(longint(d)+9),sizeof(d));
	  //RE_ENTRANT_CHECK_ON;
	  result := 1;
    exit;
	end
      else
        begin
        	result := 0;
          exit;
        end;
    end
  else if ( precision_loss )<>0 then
    begin
      (* Precision loss doesn't stop the data transfer *)
      set_precision_flag(precision_loss);
    end;

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_WRITE,@d,10);
  //RE_ENTRANT_CHECK_ON;
  i:=0;
  while i < 9 do
    begin
      b := FPU_div_small(@ll, 10);
      b :=      b or (FPU_div_small(@ll, 10)) shl 4;
      //RE_ENTRANT_CHECK_OFF;
      FPU_put_user(b,pu_char(longint(@d)+i),sizeof(d));
      //RE_ENTRANT_CHECK_ON;
      inc(i);
    end;
  //RE_ENTRANT_CHECK_OFF;
  FPU_put_user(sign,pu_char(longint(@d)+9),sizeof(d));
  //RE_ENTRANT_CHECK_ON;

  Result := 1;
end;

(*=====================================:=*)

(* r gets mangled such that sig is int, sign: 
   it is NOT normalized *)
(* The return value (in eax) is zero if the result is exact,
   if bits are changed due to rounding, truncation, etc, then
   a non-zero value is returned *)
(* Overflow is signalled by a non-zero return value (in eax).
   In the case of overflow, the returned significand always has the
   largest possible value *)


function FPU_round_to_int(r:PFPU_REG; tag:u_char):intg;
var
  very_big:u_char;
  eax:longword;
begin

  if (tag = TAG_Zero) then
    begin
      (* Make sure that zero is returned *)
      r^.sigh := 0;
      Result:= 0;        (* o.k. *)
      exit;
    end;

  if (exponent(r) > 63) then
    begin
      r^.sigl := r^.sigh and not 0;      (* The largest representable number *)
      result := 1;        (* overflow *)
      exit;
    end;

{$ifndef EMU_BIG_ENDIAN}
  eax := FPU_shrxs(@r^.sigl, 63 - exponent(r));
{$else}
  eax := FPU_shrxs(@r^.sigh, 63 - exponent(r));
{$endif}
  very_big := word((not (r^.sigh) or not(r^.sigl))=0);  (* test for $fff...fff *)
  case (I387.soft.cwd  and CW_RC) of
    RC_RND:
      begin
      if (word((eax  and $80000001) = $80000001))<>0(* nearest *)
	  or word(((bx_cpu.eax and $80000000)<>0) and ((r^.sigl and 1)<>0)) then	(* odd ^. even *)
	begin
	  if ( very_big )<>0 then
      begin
        result := 1;
        exit;
      end;        (* overflow *)
     inc(Significand(r)^); 
	  Result := PRECISION_LOST_UP;
	end;
  end;
    RC_DOWN:
      begin
      if (eax<>0) and (getsign(r)<>0) then
	begin
	  if ( very_big )<>0 then
      begin
        result := 1;
        exit;
      end;        (* overflow *)
	  inc(r^.sigh);
	  Result := PRECISION_LOST_UP;
	end;
  end;
    RC_UP:
      begin
      if (eax<>0) and (getsign(r)=0) then
	begin
	  if ( very_big )<>0 then
      begin
        result := 1;
        exit;
      end;        (* overflow *)
	  inc(r^.sigh);
	  Result := PRECISION_LOST_UP;
	end;
  end;
  RC_CHOP:
    begin
    end;
    end;

  Result := ifthen(bx_cpu.eax<>0 , PRECISION_LOST_DOWN , 0);

end;

(*=====================================:=*)

function fldenv(addr_modes:fpu_addr_modes; s:pu_char):pu_char;
var
  tag_word:u16;
  tag:u_char;
  i:intg;
begin
  tag_word := 0;

  if ( (addr_modes.default_mode = VM86) or
      ((addr_modes.default_mode = PM16)
      or (addr_modes.override_.operand_size = OP_SIZE_PREFIX)) ) then
    begin
      //RE_ENTRANT_CHECK_OFF;
      FPU_verify_area(VERIFY_READ, s, $0e);
      I387.soft.cwd:=FPU_get_user(s, u16(s));
      I387.soft.swd:=FPU_get_user(pu16(longint(s)+2), 2);
      tag_word:=FPU_get_user(pu16(longint(s)+4),2);
      Paddress(I387.soft.fip)^.offset:=FPU_get_user(pu16(longint(s)+6),2);
      Paddress(I387.soft.fip)^.selector:=FPU_get_user(pu16(longint(s)+8), 2);
      Paddress(I387.soft.fip)^.offset:=FPU_get_user(pu16(longint(s)+10),2);
      Paddress(I387.soft.fip)^.selector:=FPU_get_user(pu16(longint(s)+12),2);
      //RE_ENTRANT_CHECK_ON;
      longint(s) := longint(s) + $0e;
      if ( addr_modes.default_mode = VM86 ) then
	begin
	  Paddress(I387.soft.fip)^.offset := Paddress(I387.soft.fip)^.offset + (Paddress(I387.soft.fip)^.selector  and $f000) shl 4;
	  Paddress(I387.soft.fip)^.offset := Paddress(I387.soft.fip)^.offset + (Paddress(I387.soft.fip)^.selector and $f000) shl 4;
	end;
    end
  else
    begin
      //RE_ENTRANT_CHECK_OFF;
      FPU_verify_area(VERIFY_READ, s, $1c);
      I387.soft.cwd:=FPU_get_user(s, Sizeof(u16(s)));
      I387.soft.swd:=FPU_get_user(pu16(longint(s)+4), 2);
      tag_word:=FPU_get_user(pu16(longint(s)+8),2);
      Paddress(@I387.soft.fip)^.opcode:=FPU_get_user(pu16(longint(s)+12),2);
      Paddress(@I387.soft.fip)^.offset:=FPU_get_user(pu16(longint(s)+14),4);
      Paddress(@I387.soft.fip)^.selector:=FPU_get_user(pu16(longint(s)+18),4);

      //RE_ENTRANT_CHECK_ON;
      longint(s) := longint(s) + $1c;
    end;

{$ifdef PECULIAR_486}
  I387.soft.cwd := I387.soft.cwd and not $e080;
{$endif} (* PECULIAR_486 *)

  I387.soft.ftop := (I387.soft.swd shr SW_Top_Shift) and 7;

  if word(I387.soft.swd<>0) and (not (I387.soft.cwd and CW_Exceptions))<>0  then
    I387.soft.swd := I387.soft.swd or (SW_Summary or SW_Backward)
  else
    I387.soft.swd := I387.soft.swd and not (SW_Summary or SW_Backward);

  i:=0;
  while i < 8 do
    begin
      tag := I387.soft.swd  and 3;
      I387.soft.swd :=      I387.soft.swd shr 2;

      if ( tag = TAG_Empty ) then
	(* New tag is empty.  Accept it *)
      	FPU_settag(i, TAG_Empty)
      else if ( FPU_gettag(i) = TAG_Empty ) then
	begin
	  (* Old tag is empty and new tag is not empty.  New tag is determined
	     by old reg contents *)
	  if ( exponent(fpu_register(i)) = - EXTENDED_Ebias ) then
	    begin
	      if ( (fpu_register(i).sigl<>0) or (fpu_register(i).sigh<>0)=false) then
		FPU_settag(i, TAG_Zero)
	      else
		FPU_settag(i, TAG_Special);
	    end
	  else if ( exponent(fpu_register(i)) = $7fff - EXTENDED_Ebias ) then
	    begin
	      FPU_settag(i, TAG_Special);
	    end
	  else if ( fpu_register(i).sigh  and $80000000 )<>0 then
	    FPU_settag(i, TAG_Valid)
	  else
	    FPU_settag(i, TAG_Special);   (* An Un-normal *)
  	end;
      (* Else old tag is not empty and new tag is not empty.  Old tag
	 remains correct *)
   inc(i);
    end;

  Result:=s;
end;


procedure frstor(addr_modes:fpu_addr_modes; data_address:pu_char);
var
  i, regnr:intg;
  s:pu_char;
  offset,other:intg;
  fpu_reg_p:PFPU_REG;
begin
  s := fldenv(addr_modes, data_address);
  offset := (top  and 7) * sizeof(FPU_REG);
  other := 8*sizeof(FPU_REG) - offset;

  (* Copy all registers in stack order. *)
  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_READ,s,80);
{$ifndef USE_WITH_CPU_SIM}
  __copy_from_user(register_base+offset, s, other);
  if ( offset )
    __copy_from_user(register_base, s+other, offset);
{$else}
  begin

  fpu_reg_p := PFPU_REG(longint(register_base)+offset);
  while (other>0) do begin
    fpu_reg_p^.sigl:=FPU_get_user(pu_char(longint(s)), 4);
    fpu_reg_p^.sigh:=FPU_get_user(pu_char(longint(s)+4),4);
    fpu_reg_p^.exp:=FPU_get_user(pu_char(longint(s)+8),4);
    inc(fpu_reg_p);
    longint(s) := longint(s) + 10;
    other :=  other - sizeof(FPU_REG);
    end;
  fpu_reg_p := PFPU_REG(longint(register_base));
  while (offset>0) do begin
    fpu_reg_p^.sigl:=FPU_get_user(pu_char(longint(s)), 4);
    fpu_reg_p^.sigh:=FPU_get_user(pu_char(longint(s)+4),4);
    fpu_reg_p^.exp:=FPU_get_user(pu_char(longint(s)+8),4);
    inc(fpu_reg_p);
{    FPU_get_user(fpu_reg_p^.sigl, (u32*)(s+0));
    FPU_get_user(fpu_reg_p^.sigh, (u32*)(s+4));
    FPU_get_user(fpu_reg_p^.exp,  (u16*)(s+8));
    fpu_reg_p++;}
    longint(s) := longint(s) + 10;
    offset :=    offset - sizeof(FPU_REG);
    end;
  end;
{$endif}
  //RE_ENTRANT_CHECK_ON;

  i:=0;
  while i < 8 do
    begin
      regnr := (i+top)  and 7;
      if ( FPU_gettag(regnr) <> TAG_Empty ) then
	(* The loaded data over-rides all other cases. *)
	FPU_settag(regnr, FPU_tagof(st(i)));
  inc(i);
    end;

end;


function fstenv(addr_modes:fpu_addr_modes; d:pu_char):pu_char;
begin
  if ( (addr_modes.default_mode = VM86) or
      ((addr_modes.default_mode = PM16)
      or (addr_modes.override_.operand_size = OP_SIZE_PREFIX)) ) then
    begin
      //RE_ENTRANT_CHECK_OFF;
      FPU_verify_area(VERIFY_WRITE,d,14);
{$ifdef PECULIAR_486}
      FPU_put_user(I387.soft.cwd  and not $e080, pu32(d),sizeof(d^));
{$else}
      FPU_put_user(I387.soft.cwd, (u16 *) d);
{$endif} (* PECULIAR_486 *)
      FPU_put_user(((i387.soft.swd) and not $3800 and $ffff) or (((i387.soft.ftop) shl 11) and $3800), pu16(longint(d)+2),sizeof(d^));
      FPU_put_user(Paddress(I387.soft.fip)^.offset, pu16(longint(d)+4),sizeof(d^));
      FPU_put_user(Paddress(I387.soft.fip)^.offset, pu16(longint(d)+6),sizeof(d^));
      FPU_put_user(Paddress(I387.soft.fip)^.offset, pu16(longint(d)+10),sizeof(d^));
      if ( addr_modes.default_mode = VM86 ) then
	begin
	  FPU_put_user((Paddress(I387.soft.fip)^.offset  and $f0000) shr 4, pu16(longint(d)+8),sizeof(d^));
	  FPU_put_user((Paddress(I387.soft.fip)^.offset  and $f0000) shr 4, pu16(longint(d)+10),sizeof(d^));
	end
      else
	begin
	  FPU_put_user((Paddress(I387.soft.fip)^.selector) shr 4, pu16(longint(d)+8),sizeof(d^));
	  FPU_put_user((Paddress(I387.soft.fip)^.selector) shr 4, pu16(longint(d)+10),sizeof(d^));
	end;
      //RE_ENTRANT_CHECK_ON;
      longint(d) :=      longint(d) + $0e;
    end
  else
    begin
      //RE_ENTRANT_CHECK_OFF;
      FPU_verify_area(VERIFY_WRITE, d, 7*4);
{$ifdef PECULIAR_486}
      I387.soft.cwd := I387.soft.cwd and not $e080;
      (* An 80486 sets nearly all of the reserved bits to 1. *)
      I387.soft.cwd :=      I387.soft.cwd or $ffff0040;
      I387.soft.swd := ((i387.soft.swd) and not $3800 and $ffff) or (((i387.soft.ftop) shl 11) and $3800) or $ffff0000;
      i387.soft.twd :=      i387.soft.twd or $ffff0000;
      I387.soft.fcs := I387.soft.fcs and not $f8000000;
      I387.soft.fos :=      I387.soft.fos or $ffff0000;
{$endif} (* PECULIAR_486 *)
{$ifndef USE_WITH_CPU_SIM}
      __copy_to_user(d, @I387.soft.cwd, 7*4);
{$else}
      FPU_put_user(u32(I387.soft.cwd), pu32(pu8(d)),sizeof(d^));
      FPU_put_user(u32(I387.soft.swd), pu32(pu8(longint(d)+4)),sizeof(d^));
      FPU_put_user(u32(I387.soft.twd), pu32(pu8(longint(d)+8)),sizeof(d^));
      FPU_put_user(u32(I387.soft.fip), pu32(pu8(longint(d)+12)),sizeof(d^));
      FPU_put_user(u32(I387.soft.fcs), pu32(pu8(longint(d)+16)),sizeof(d^));
      FPU_put_user(u32(I387.soft.foo), pu32(pu8(longint(d)+20)),sizeof(d^));
      FPU_put_user(u32(I387.soft.fos), pu32(pu8(longint(d)+24)),sizeof(d^));
{$endif}
      //RE_ENTRANT_CHECK_ON;
      longint(d) :=  longint(d) + $1c;
    end;
  
  I387.soft.cwd :=  I387.soft.cwd or CW_Exceptions;
  I387.soft.swd := I387.soft.swd and not (SW_Summary or SW_Backward);

  Result := d;
end;


procedure fsave(addr_modes:fpu_addr_modes; data_address:pu_char);
var
  d:pu_char;
  offset,other:intg;
  fpu_reg_p:PFPU_REG;
begin
  offset := (top  and 7) * sizeof(FPU_REG);
  other := 8*sizeof(FPU_REG) - offset;

  d := fstenv(addr_modes, data_address);

  //RE_ENTRANT_CHECK_OFF;
  FPU_verify_area(VERIFY_WRITE,d,80);

  (* Copy all registers in stack order. *)
{$ifndef USE_WITH_CPU_SIM}
  __copy_to_user(d, register_base+offset, other);
  if ( offset )
    __copy_to_user(d+other, register_base, offset);
{$else}
  begin

  fpu_reg_p := PFPU_REG(longint(register_base)+offset);
  while (other>0) do begin
    FPU_put_user(fpu_reg_p^.sigl, pu32(d),sizeof(d^));
    FPU_put_user(fpu_reg_p^.sigh, pu32(longint(d)+4),sizeof(d^));
    FPU_put_user(fpu_reg_p^.exp,  pu16(longint(d)+8),sizeof(d^));
    inc(fpu_reg_p);
    longint(d) := longint(d) + 10;
    other :=    other - sizeof(FPU_REG);
    end;
  fpu_reg_p := PFPU_REG(register_base);
  while (offset>0) do begin
    FPU_put_user(fpu_reg_p^.sigl, pu32(d),sizeof(d^));
    FPU_put_user(fpu_reg_p^.sigh, pu32(longint(d)+4),sizeof(d^));
    FPU_put_user(fpu_reg_p^.exp,  pu16(longint(d)+8),sizeof(d^));
    inc(fpu_reg_p);
    longint(d) :=  longint(d) + 10;
    offset :=    offset - sizeof(FPU_REG);
    end;
  end;
{$endif}
  //RE_ENTRANT_CHECK_ON;

  finit();
end;

end.
