ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/ERROR87.ZIP/ERROR87.PAS

Pascal/Delphi Source File | 1990-08-15 | 9.6 KB | 343 lines

{$n+}
unit error87;

interface

implementation

uses decode87;

type
  controlword = set of (Invalidmask, Denormmask, Zerodivmask, Overflowmask,
                        Underflowmask, Precisionmask,
                        CReserved6, IntEnable, Precision0, Precision1, Round0,
                        Round1, Infinity, CReserved13, CReserved14,
                        CReserved15);

  statusword = set of (Invalid, Denorm, Zerodiv, Overflow, Underflow, Precision,
                       SReserved6, IntRequest, C0, C1, C2, ST0, ST1, ST2, C3,
                       Busy);
  bitnumbers = 0..15;
  state87  = record
               control  : controlword;
               status   : statusword;
               tags,
               ip15_0,
               ip_opcode,
               op15_0,
               op19_16  : Word;
               stack    : array[0..7] of Extended;
             end;

  function single_infinite(var s : Single) : Boolean;
  begin
    if (LongInt(s) and $7FFFFFFF) = $7F800000 then
      single_infinite := True
    else
      single_infinite := False;
  end;

  function single_nan(var s : Single) : Boolean;
  var
    words    : array[1..2] of Word absolute s;
  begin
    single_nan := False;
    if ((words[2] and $7F80) = $7F80) and (not single_infinite(s)) then
      single_nan := True;
  end;

  function double_infinite(var d : Double) : Boolean;
  var
    longs    : array[1..2] of LongInt absolute d;
  begin
    if (longs[2] = $7FFFFFFF) and (longs[1] = 0) then
      double_infinite := True
    else
      double_infinite := False;
  end;

  function double_nan(var d : Double) : Boolean;
  var
    words    : array[1..4] of Word absolute d;
  begin
    double_nan := False;
    if (words[4] and $7FF0) = $7FF0 then { not a number, but maybe INF }
      if not double_infinite(d) then
        double_nan := True;
  end;

  function extended_infinite(var e : Extended) : Boolean;
  var
    words    : array[1..5] of Word absolute e;
  begin
    if ((words[5] and $7FFF) = $7FFF)
    and (words[4] = $8000)
    and (words[3] = 0)
    and (words[2] = 0)
    and (words[1] = 0) then
      extended_infinite := True
    else
      extended_infinite := False;
  end;

  function extended_nan(var e : Extended) : Boolean;
  var
    words    : array[1..5] of Word absolute e;
  begin
    extended_nan := False;
    if ((words[5] and $7FFF) = $7FFF) and
    ((words[4] and $8000) = $8000) then { not a number, but maybe INF }
      if not extended_infinite(e) then
        extended_nan := True;
  end;

  function bcd_zero(var b)   : Boolean;
  var
    words    : array[1..5] of Word absolute b;
  begin
    bcd_zero := False;
    if ((words[5] and $7FFF) = 0)
    and (words[4] = 0)
    and (words[3] = 0)
    and (words[2] = 0)
    and (words[1] = 0) then
      bcd_zero := True;
  end;

var
  state    : state87;  { In data segment, in case there isn't much stack
                         space }
var
  oldexitproc : Pointer;
{$f+}
  procedure my_exit_proc;
  var
    opcode   : Word;
    last_inst : opcode_info;
    ops_read : operand_set;
    regs_read : operand_set;
    op_address, ip_address : Pointer;
    tos      : 0..7;
    op       : operand_type;
    danger   : Boolean;

    function physical(reg : operand_type) : Byte;
      { Return the physical register number of a register }
    begin
      physical := (Ord(reg)+tos) mod 8;
    end;

    function tag(reg : operand_type) : Byte;
    begin
      tag := (state.tags shr (2*physical(reg))) and 3;
    end;

    function is_a_Nan(op : operand_type) : Boolean;
    begin
      is_a_Nan := False;
      case op of
        arReg0..arReg7 : begin
                           if tag(op) <> 2 then
                             Exit;
                           is_a_Nan := extended_nan(state.stack[ord(op)]);
                         end;
        arSingle : is_a_Nan := single_nan(Single(op_address^));
        arDouble : is_a_Nan := double_nan(Double(op_address^));
        arExtended : is_a_Nan := extended_nan(Extended(op_address^));
      end;
      { others can't be NaNs }
    end;

    function is_a_zero(op : operand_type) : Boolean;
    begin
      is_a_zero := False;
      case op of
        arReg0..arReg7 : begin
                           if tag(op) = 1 then
                             is_a_zero := True;
                         end;
        arSingle :
          is_a_zero := (Single(op_address^) = 0.0);
        arDouble :
          is_a_zero := (Double(op_address^) = 0.0);
        arExtended :
          is_a_zero := (Extended(op_address^) = 0.0);
        arWord :
          is_a_zero := (Word(op_address^) = 0);
        arLongint :
          is_a_zero := (LongInt(op_address^) = 0);
        arComp :
          is_a_zero := (Comp(op_address^) = 0);
        arBCD :
          is_a_zero := bcd_zero(op_address^);
      end;
    end;

  function PtrToLong(p:pointer):longint;
  begin
    PtrToLong := longint(seg(p^)) shl 4 + ofs(p^);
  end;

  function PtrDiff(p1,p2:pointer):longint;
  begin
    PtrDiff := abs(PtrToLong(p1)-PtrToLong(p2));
  end;

  procedure adjust_for_prefix;
  var
    temp : longint;
  begin
    temp := PtrToLong(ip_address)-longint(prefixseg)*$10-$100;
    { this is the linear address relative to the start of the program }
    ip_address := ptr((temp and $FFFF0000) shl 12, temp and $FFFF);
      { ip_address will have smallest possible segment number }
      { User must manually work out true segment value }
  end;

  procedure rangecheck(lower,upper:extended);
  var
    reg : operand_type;
  begin
    if (last_inst.inst = iFISTP) and (tag(arReg0) = 3) then
      reg := arReg7  { This doesn't really belong here, but
                       a pop happens in trunc() because it temporarily
                       masks exceptions. }
    else
      reg := arReg0;
    danger :=   (state.stack[ord(reg)] < lower)
             or (state.stack[ord(reg)] > upper);
  end;

  begin                           {my_exit_proc}
    ExitProc := oldexitproc;
    if (ErrorAddr = nil) or (ExitCode <> 207) then
      Exit;

    inline($cd/$39/$36/state/$9b);
    opcode := state.ip_opcode and $07FF+$d800;
    decode_opcode(opcode, last_inst);
    operands_read(last_inst, ops_read);
    regs_read := ops_read*[arReg0..arReg7];

    op_address := Ptr(state.op19_16 and $F000, state.op15_0);
    ip_address := Ptr(state.ip_opcode and $F000, state.ip15_0);

    adjust_for_prefix;  { Make ip_address on same scale as ErrorAddr }

    if ptrdiff(ErrorAddr,ip_address) > 10 then
      ErrorAddr := ip_address;

    tos := (Word(state.status) shr 11) and 7;

    { Look for bad square root }
    if last_inst.inst = iFSQRT then
      if state.stack[ord(arReg0)] < 0.0 then
      begin
        WriteLn('Taking the square root of a negative!');
        Exit;
      end;

    { Look for zero by zero divide }
    if last_inst.inst in [iFDIV, iFDIVP, iFIDIV, iFDIVR, iFDIVRP, iFIDIVR] then
    begin
      danger := True;
      for op := arReg0 to arExtended do
        if op in ops_read then
          if not is_a_zero(op) then
            danger := False;
      if danger then
      begin
        WriteLn('Zero divided by zero!');
        Exit;
      end;
    end;

    { Look for stack overflow }

    for op := operand_type(8-num_pushes(last_inst)) to arReg7 do
      if tag(op) <> 3 then
      begin
        WriteLn('Coprocessor stack overflow!');
        Exit;
      end;

    { Look for NANs }

    if ops_read <> [] then
      for op := arReg0 to arExtended do
        if op in ops_read then
          if is_a_Nan(op) then
          begin
            WriteLn('Operand is not a number!');
            Exit;
          end;

    { Look for truncation errors.  Note that, contrary to the docs,
      the stack may have been popped, so this has to come before the
      underflow check }
    if last_inst.inst in [iFIST,iFISTP] then
    begin
      { Should check rounding mode, but I'm too lazy! }
      case last_inst.arg1 of
      arWord:     rangecheck(-32768.5,32767.5);
      arLongint:  rangecheck(-2147483648.5,2147483647.5);
      arComp:     rangecheck(-9223372036854775808.5,
                              9223372036854775807.5);
      end;
      if danger then
      begin
        WriteLn('Value too large to store in integer!');
        Exit;
      end;
    end;

    { Look for stack underflow }

    if regs_read <> [] then
      for op := arReg0 to arReg7 do { i is logical register number }
        if op in regs_read then
          if tag(op) = 3 then
          begin
            WriteLn('Coprocessor stack underflow!');
            Exit;
          end;

    WriteLn('Unrecognized floating point error!');

  end;

  function patch_system : Boolean;
    { Patches system unit so that  8087 is not cleared on error }
  type
    one_instruction = array[1..3] of Byte;
  const
    before   : one_instruction = ($cd, $37, $e3); { FINIT }
    after    : one_instruction = ($cd, $37, $e2); { FCLEX }

  var
    int02_handler : Pointer absolute 0 : 8;
    patch_site : ^one_instruction;
    b        : Byte;
  begin
    patch_site := Ptr(Seg(int02_handler^), Ofs(int02_handler^)+$32);
    for b := 1 to 3 do
      if patch_site^[b] <> before[b] then
      begin
        patch_system := False;
        Exit;
      end;
    patch_site^ := after;
    patch_system := True;
  end;

begin
  if patch_system then
  begin
    oldexitproc := ExitProc;
    ExitProc := @my_exit_proc;
  end
  else
    WriteLn(
      'Error87 is unable to find the patch point., and is not installing itself');
end.