{**************************************************************************************************}
{ }
{ Project JEDI Code Library (JCL) }
{ }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
{ License at http://www.mozilla.org/MPL/ }
{ }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
{ and limitations under the License. }
{ }
{ The Original Code is Jcl8087.pas. }
{ }
{ The Initial Developers of the Original Code are documented in the accompanying help file }
{ JCLHELP.hlp. Portions created by these individuals are Copyright (C) of these individuals. }
{ }
{**************************************************************************************************}
{ }
{ This unit contains various routine for manipulating the math coprocessor. This includes such }
{ things as querying and setting the rounding precision of floating point operations and }
{ retrieving the coprocessor's status word. }
{ }
{ Unit owner: Marcel van Brakel }
{ }
{**************************************************************************************************}
// $Id: Jcl8087.pas,v 1.2 2004/04/14 21:55:07 druid Exp $
// rr 2003-10-12:
// Removed references to Default8087CW because of compiler problems when including Jcl8087 in
// package (D7, I remember having seen that with D5, too; Kylix 3 however went smoothly). Error
// message was, in spite of {$IMPORTEDDATA ON}:
// "Need imported data reference ($G) to access Default8087CW".
unit Jcl8087;
{$I jcl.inc}
{$IFDEF SUPPORTS_WEAKPACKAGEUNIT}
{$WEAKPACKAGEUNIT ON}
{$ENDIF SUPPORTS_WEAKPACKAGEUNIT}
interface
type
T8087Precision = (pcSingle, pcReserved, pcDouble, pcExtended);
T8087Rounding = (rcNearestOrEven, rcDownInfinity, rcUpInfinity, rcChopOrTruncate);
T8087Infinity = (icProjective, icAffine);
T8087Exception = (emInvalidOp, emDenormalizedOperand, emZeroDivide, emOverflow,
emUnderflow, emPrecision);
T8087Exceptions = set of T8087Exception;
const
All8087Exceptions = [Low(T8087Exception)..High(T8087Exception)];
function Get8087ControlWord: Word;
function Get8087Infinity: T8087Infinity;
function Get8087Precision: T8087Precision;
function Get8087Rounding: T8087Rounding;
function Get8087StatusWord(ClearExceptions: Boolean): Word;
function Set8087Infinity(const Infinity: T8087Infinity): T8087Infinity;
function Set8087Precision(const Precision: T8087Precision): T8087Precision;
function Set8087Rounding(const Rounding: T8087Rounding): T8087Rounding;
function Set8087ControlWord(const Control: Word): Word;
function ClearPending8087Exceptions: T8087Exceptions;
function GetPending8087Exceptions: T8087Exceptions;
function GetMasked8087Exceptions: T8087Exceptions;
function SetMasked8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean = True): T8087Exceptions;
function Mask8087Exceptions(Exceptions: T8087Exceptions): T8087Exceptions;
function Unmask8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean = True): T8087Exceptions;
implementation
const
X87ExceptBits = $3F;
//--------------------------------------------------------------------------------------------------
function Get8087ControlWord: Word; assembler;
asm
{$IFNDEF FPC}
SUB ESP, TYPE WORD
{$ELSE}
SUB ESP, $2
{$ENDIF}
FSTCW [ESP]
FWAIT
POP AX
end;
//--------------------------------------------------------------------------------------------------
function Get8087Infinity: T8087Infinity;
begin
Result := T8087Infinity((Get8087ControlWord and $1000) shr 12);
end;
//--------------------------------------------------------------------------------------------------
function Get8087Precision: T8087Precision;
begin
Result := T8087Precision((Get8087ControlWord and $0300) shr 8);
end;
//--------------------------------------------------------------------------------------------------
function Get8087Rounding: T8087Rounding;
begin
Result := T8087Rounding((Get8087ControlWord and $0C00) shr 10);
end;
//--------------------------------------------------------------------------------------------------
function Get8087StatusWord(ClearExceptions: Boolean): Word; assembler;
asm
TEST AX, AX // if ClearExceptions then
JE @@NoClearExceptions
FSTSW AX // get status word (clears exceptions)
RET
@@NoClearExceptions: // else
FNSTSW AX // get status word (without clearing exceptions)
end;
//--------------------------------------------------------------------------------------------------
function Set8087Infinity(const Infinity: T8087Infinity): T8087Infinity;
var
CW: Word;
begin
CW := Get8087ControlWord;
Result := T8087Infinity((CW and $1000) shr 12);
Set8087ControlWord((CW and $EFFF) or (Word(Infinity) shl 12));
end;
//--------------------------------------------------------------------------------------------------
function Set8087Precision(const Precision: T8087Precision): T8087Precision;
var
CW: Word;
begin
CW := Get8087ControlWord;
Result := T8087Precision((CW and $0300) shr 8);
Set8087ControlWord((CW and $FCFF) or (Word(Precision) shl 8));
end;
//--------------------------------------------------------------------------------------------------
function Set8087Rounding(const Rounding: T8087Rounding): T8087Rounding;
var
CW: Word;
begin
CW := Get8087ControlWord;
Result := T8087Rounding((CW and $0C00) shr 10);
Set8087ControlWord((CW and $F3FF) or (Word(Rounding) shl 10));
end;
//--------------------------------------------------------------------------------------------------
function Set8087ControlWord(const Control: Word): Word; assembler;
asm
FNCLEX
{$IFNDEF FPC}
SUB ESP, TYPE WORD
{$ELSE}
SUB ESP, $2
{$ENDIF}
FSTCW [ESP]
XCHG [ESP], AX
FLDCW [ESP]
{$IFNDEF FPC}
ADD ESP, TYPE WORD
{$ELSE}
ADD ESP, $2
{$ENDIF}
end;
//--------------------------------------------------------------------------------------------------
function ClearPending8087Exceptions: T8087Exceptions;
asm
FNSTSW AX
AND AX, X87ExceptBits
FNCLEX
end;
//--------------------------------------------------------------------------------------------------
function GetPending8087Exceptions: T8087Exceptions;
asm
FNSTSW AX
AND AX, X87ExceptBits
end;
//--------------------------------------------------------------------------------------------------
function GetMasked8087Exceptions: T8087Exceptions;
asm
{$IFNDEF FPC}
SUB ESP, TYPE WORD
{$ELSE}
SUB ESP, $2
{$ENDIF}
FSTCW [ESP]
FWAIT
POP AX
AND AX, X87ExceptBits
end;
//--------------------------------------------------------------------------------------------------
function SetMasked8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean): T8087Exceptions;
asm
TEST DL, DL // if ClearBefore then
JZ @1
FNCLEX // clear pending exceptions
@1:
{$IFNDEF FPC}
SUB ESP, TYPE WORD
{$ELSE}
SUB ESP, $2
{$ENDIF}
FSTCW [ESP]
FWAIT
AND AX, X87ExceptBits // mask exception mask bits 0..5
MOV DX, [ESP]
AND WORD PTR [ESP], NOT X87ExceptBits
OR [ESP], AX
FLDCW [ESP]
{$IFNDEF FPC}
ADD ESP, TYPE WORD
{$ELSE}
ADD ESP, $2
{$ENDIF}
MOV AX, DX
AND AX, X87ExceptBits
end;
//--------------------------------------------------------------------------------------------------
function Mask8087Exceptions(Exceptions: T8087Exceptions): T8087Exceptions;
begin
Result := GetMasked8087Exceptions;
Exceptions := Exceptions + Result;
SetMasked8087Exceptions(Exceptions, False);
end;
//--------------------------------------------------------------------------------------------------
function Unmask8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean): T8087Exceptions;
begin
Result := GetMasked8087Exceptions;
Exceptions := Result - Exceptions;
SetMasked8087Exceptions(Exceptions, ClearBefore);
end;
end.