unit reg_mul;

interface

uses fpu_types;

function FPU_mul (b: PFPU_REG; tagb: u_char; deststnr: intg; control_w: intg): intg;

implementation

uses Service_fpu, errors, fpu_system, reg_convert;

function FPU_mul (b: PFPU_REG; tagb: u_char; deststnr: intg; control_w: intg): intg;
  var
    a: PFPU_REG;
    dest: PFPU_REG;
    taga: u_char;
    saved_sign: u_char;
    sign: u_char;
    tag: intg;
    x, y: FPU_REG;
  begin
    a := st(deststnr);
    dest := a;
    taga := FPU_gettagi(deststnr);
    saved_sign := getsign(dest);
    sign := (getsign(a) or getsign(b));

    if ((taga or tagb) = 0) then
      begin
      (* Both regs Valid, this should be the most common case. *)

      tag := FPU_u_mul(a, b, dest, control_w, sign, exponent(a) + exponent(b));
      if (tag < 0) then
        begin
        setsign(dest, saved_sign);
        Result := tag;
        exit;
        end;
      FPU_settagi(deststnr, tag);
      Result := tag;
      exit;
      end;

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

    if (((taga = TAG_Valid) and (tagb = TW_Denormal)) or
      ((taga = TW_Denormal) and (tagb = TAG_Valid)) or
      ((taga = TW_Denormal) and (tagb = TW_Denormal))) then
      begin
      if (denormal_operand() < 0) then
        begin
        Result := FPU_Exception_c;
        Exit;
        end;

      FPU_to_exp16(a, @x);
      FPU_to_exp16(b, @y);
      tag := FPU_u_mul(@x, @y, dest, control_w, sign, exponent16(@x) +
        exponent16(@y));
      if (tag < 0) then
        begin
        setsign(dest, saved_sign);
        Result := tag;
        Exit;
        end;
      FPU_settagi(deststnr, tag);
      Result := tag;
      Exit;
      end
    else
      if ((taga <= TW_Denormal) and (tagb <= TW_Denormal)) then
        begin
        if (((tagb = TW_Denormal) or (taga = TW_Denormal)) and
          (denormal_operand() < 0)) then
          begin
          Result := FPU_Exception_c;
          Exit;
          end;

      (* Must have either both arguments = zero, or
   one valid and the other zero.
   The result is therefore zero. *)
        FPU_copy_to_regi(@CONST_Z, TAG_Zero, deststnr);
      (* The 80486 book says that the answer is +0, but a real
   80486 behaves this way.
   IEEE-754 apparently says it should be this way. *)
        setsign(dest, sign);
        Result := TAG_Zero;
        Exit;
        end
      (* Must have infinities, NaNs, etc *)
      else
        if ((taga = TW_NaN) or (tagb = TW_NaN)) then
          begin
          Result := real_2op_NaN(b, tagb, deststnr, st(0));
          Exit;
          end
        else
          if (((taga = TW_Infinity) and (tagb = TAG_Zero)) or
            ((tagb = TW_Infinity) and (taga = TAG_Zero))) then
            begin
            Result := arith_invalid(deststnr);  (* Zero*Infinity is invalid *)
            Exit;
            end
          else
            if (((taga = TW_Denormal) or (tagb = TW_Denormal)) and
              (denormal_operand() < 0)) then
              begin
              Result := FPU_Exception_c;
              Exit;
              end
            else
              if (taga = TW_Infinity) then
                begin
                FPU_copy_to_regi(a, TAG_Special, deststnr);
                setsign(dest, sign);
                Result := TAG_Special;
                Exit;
                end
              else
                if (tagb = TW_Infinity) then
                  begin
                  FPU_copy_to_regi(b, TAG_Special, deststnr);
                  setsign(dest, sign);
                  Result := TAG_Special;
                  Exit;
                  end;

{$ifdef PARANOID}
  else
    begin
      EXCEPTION(EX_INTERNAL|$102);
      return FPU_Exception;
    end;
{$endif}(* PARANOID *)

  end;

end.
