-- IeeeFloatB.mesa
-- Last Modified: August 27, 1982 11:27 am
-- Last Modified By Paul Rovner On May 4, 1983 9:55 am
-- Mesa implementation of floating point ops
-- Last Edited by: Levin, August 8, 1983 4:32 pm

DIRECTORY
  Basics USING [LongNumber],
  Ieee,
  PrincOps USING [zDCOMP],
  PrincOpsUtils USING [BITAND, BITOR],
  Real,
  RealOps;

IeeeFloatB: PROGRAM IMPORTS Ieee, PrincOpsUtils, Real EXPORTS Ieee, RealOps =
  BEGIN OPEN Ieee, Real, RealOps;
  
  sqGuesses: ARRAY[0..32) OF REAL ← [
    LOOPHOLE[7715741440B, REAL],
    LOOPHOLE[7717240700B, REAL],
    LOOPHOLE[7720514140B, REAL],
    LOOPHOLE[7721745140B, REAL],
    LOOPHOLE[7723155200B, REAL],
    LOOPHOLE[7724346000B, REAL],
    LOOPHOLE[7725517500B, REAL],
    LOOPHOLE[7726654000B, REAL],

    LOOPHOLE[7727773400B, REAL],
    LOOPHOLE[7731077100B, REAL],
    LOOPHOLE[7732167300B, REAL],
    LOOPHOLE[7733245000B, REAL],
    LOOPHOLE[7734310400B, REAL],
    LOOPHOLE[7735342500B, REAL],
    LOOPHOLE[7736363400B, REAL],
    LOOPHOLE[7737373700B, REAL],

    LOOPHOLE[7740370240B, REAL],
    LOOPHOLE[7741351440B, REAL],
    LOOPHOLE[7742314540B, REAL],
    LOOPHOLE[7743243000B, REAL],
    LOOPHOLE[7744155200B, REAL],
    LOOPHOLE[7745054400B, REAL],
    LOOPHOLE[7745741300B, REAL],
    LOOPHOLE[7746614600B, REAL],

    LOOPHOLE[7747457040B, REAL],
    LOOPHOLE[7750310640B, REAL],
    LOOPHOLE[7751132500B, REAL],
    LOOPHOLE[7751745000B, REAL],
    LOOPHOLE[7752550100B, REAL],
    LOOPHOLE[7753344400B, REAL],
    LOOPHOLE[7754132600B, REAL],
    LOOPHOLE[7754712500B, REAL]];



  FComp: PUBLIC SAFE PROC [a, b: REAL, m: Mode] RETURNS [INTEGER] = TRUSTED {
    x, y: Ieee.Ext;
    {
    fpmode ← m;
    thisTimeExceptions ← Real.NoExceptions;
    x ← Ieee.Unpack[a];
    y ← Ieee.Unpack[b];
    IF Ieee.BitOn[funny, PrincOpsUtils.BITOR[x.det, y.det]] THEN
      SELECT TRUE FROM
	x.det.type = nan => GOTO InvX;
	y.det.type = nan => GOTO InvY;
	x.det.type # infinity AND y.det.type # infinity => NULL;
	x.det.type = infinity AND y.det.type = infinity =>
	  IF fpmode.im = projective OR x.det.sign = y.det.sign THEN GOTO Equal
	  ELSE GOTO XSign;
	fpmode.im = projective => GOTO InvX;
	x.det.type = infinity => GOTO XSign;
	y.det.type = infinity => GOTO YSign;
	ENDCASE => ERROR
    ELSE
      SELECT Ieee.NormalType[x.det, y.det] FROM
	TNnn => NULL;
	TNnz => GOTO XSign;
	TNzn => GOTO YSign;
	TNzz => GOTO Equal;
	ENDCASE => ERROR;
    IF x.det.sign # y.det.sign THEN GOTO XSign;
    IF x.det.sign THEN
      BEGIN
      LOOPHOLE[a, LONG INTEGER] ← MagicLI - LN[a].li;
      LOOPHOLE[b, LONG INTEGER] ← MagicLI - LN[b].li;
      END;
    EXITS
      XSign => RETURN[IF x.det.sign THEN -1 ELSE 1];
      YSign => RETURN[IF y.det.sign THEN 1 ELSE -1];
      Equal => RETURN[0];
      InvX => InvalidAndDie[@x];
      InvY => InvalidAndDie[@y];
    };
    RETURN[zFComp[a, b]];
    };

  zFComp: PROC [a, b: REAL] RETURNS [INTEGER] = MACHINE CODE {PrincOps.zDCOMP; };

    Float: PUBLIC SAFE PROC [a: LONG INTEGER, m: RealOps.Mode] RETURNS [REAL] = TRUSTED {
      x: Ieee.Ext;
      fpmode ← m;
      thisTimeExceptions ← Real.NoExceptions;
      IF a = 0 THEN RETURN[PlusZero];
      x.det.sign ← a < 0;
      x.frac.li ← IF x.det.sign THEN -a ELSE a;
      x.det.sticky ← FALSE;
      x.det.type ← normal;
      x.exp ← 31;
      Ieee.PostNormalize[@x];
      Ieee.Round[@x];
      RETURN[Ieee.Pack[@x]];
      };

    RoundLI: PUBLIC SAFE PROC [a: REAL, m: RealOps.Mode] RETURNS [LONG INTEGER] = TRUSTED {
      x: Ieee.Ext;
      fli: LONG INTEGER;
      inv, ov: BOOLEAN;
      fpmode ← m;
      thisTimeExceptions ← Real.NoExceptions;
      x ← Unpack[a];
      [v: fli, invalid: inv, overflow: ov] ← FixExtended[x, fpmode.round];
      IF inv THEN InvalidAndDie[@x];
      IF ov THEN {
	Ieee.SetFixOverflow[];
	IF fpmode.traps[fixOverflow] THEN {
	  p: REF Real.Extended ← NEW[Real.Extended ← Ieee.CVExtended[x]];
	  IF SIGNAL Real.RealException[thisTimeExceptions, p] THEN RETURN[LOOPHOLE[p↑.frac, LONG INTEGER]];
	  };
	};
      RETURN[fli];
      };

    FixExtended: PUBLIC SAFE PROC [z: Ieee.Ext, rmode: RealOps.RoundingMode]
      RETURNS [v: LONG INTEGER, invalid, overflow: BOOLEAN] = TRUSTED {
      grs: INTEGER;
      {
      SELECT z.det.type FROM
	nan => GOTO Invalid;
	infinity => GOTO Invalid;
	zero => GOTO Zero;
	normal => NULL;
	ENDCASE => ERROR;
      IF z.exp > 30 THEN GOTO Overflow;
      {
      IF z.exp = 30 THEN {
	grs ← IF Ieee.BitOn[z.frac.lowbits, 1] THEN 4 ELSE 0;
	z.frac.lc ← Ieee.RShift[z.frac.lc];
	}
      ELSE {
	Ieee.DeNormalize[@z, z.exp - 29];
	grs ← PrincOpsUtils.BITAND[z.frac.lowbits, 3B];
	grs ← grs + grs;
	z.frac.lc ← Ieee.LongShift[z.frac.lc, -2];
	};
      IF z.det.sticky THEN grs ← grs + 1;
      SELECT rmode FROM
	rn => {
	  IF grs > 4 OR (grs = 4 AND Ieee.BitOn[z.frac.lowbits, 1]) THEN
	    GOTO Plus1;
	  };
	rz => NULL;
	rm => IF z.det.sign THEN GOTO Plus1;
	rp => IF NOT z.det.sign THEN GOTO Plus1;
	ENDCASE => ERROR;
      EXITS
	Plus1 => {
	  z.frac.lc ← z.frac.lc + 1;
	  IF Ieee.BitOn[z.frac.highbits, HiBit] THEN GOTO Overflow;
	  };
      };
      EXITS
	Overflow => {
	  IF z.det.sign AND z.frac.li = MagicLI THEN
	    RETURN[v: MagicLI, invalid: FALSE, overflow: FALSE];
	  -- returns positive without looking at sign
	  z.frac.li ← Ieee.LongShift[z.frac.li, z.exp - 30];
	  z.frac.highbits ← PrincOpsUtils.BITAND[NotHiBit, z.frac.highbits];
	  RETURN[v: z.frac.li, invalid: FALSE, overflow: TRUE];
	  };
	Invalid => RETURN[v: z.frac.li, invalid: TRUE, overflow: FALSE];
	Zero => RETURN[v: 0, invalid: FALSE, overflow: FALSE];
      };
      IF z.det.sign THEN z.frac.li ← -z.frac.li;
      RETURN[v: z.frac.li, invalid: FALSE, overflow: FALSE];
      };

    InvalidAndDie: PROC [z: POINTER TO Ieee.Ext] = {
      p: REF Real.Extended ← NEW[Real.Extended ← Ieee.CVExtended[z↑]];
      Ieee.SetInvalidOperation[];
      [] ← SIGNAL Real.RealException[thisTimeExceptions, p];
      ERROR Real.RealError;
      };

    RoundI: PUBLIC SAFE PROC [a: REAL, m: RealOps.Mode] RETURNS [INTEGER] = TRUSTED {
      x: Ieee.Ext;
      fli: LONG INTEGER;
      fi: INTEGER;
      inv, ov: BOOLEAN;
      fpmode ← m;
      thisTimeExceptions ← NoExceptions;
      x ← Ieee.Unpack[a];
      [v: fli, invalid: inv, overflow: ov] ← FixExtended[x, fpmode.round];
      IF inv THEN InvalidAndDie[@x];
      IF ov OR fli NOT IN [FIRST[INTEGER]..LAST[INTEGER]] THEN {
	Ieee.SetFixOverflow[];
	IF fpmode.traps[fixOverflow] THEN {
	  p: REF Real.Extended ← NEW[Real.Extended ← Ieee.CVExtended[x]];
	  IF SIGNAL Real.RealException[thisTimeExceptions, p] THEN RETURN[LOOPHOLE[p↑.frac, Basics.LongNumber].lowbits];
	  }; -- FixExtended returns low 31 bits of integer part of fraction
	IF NOT ov AND x.det.sign THEN fli ← -fli;
	fi ← PrincOpsUtils.BITAND[NotHiBit, LOOPHOLE[fli, Basics.LongNumber].lowbits];
	}
      ELSE fi ← LOOPHOLE[fli, Basics.LongNumber].lowbits;
      RETURN[fi];
      };

    RoundC: PUBLIC SAFE PROC [a: REAL, m: RealOps.Mode] RETURNS [CARDINAL] = TRUSTED {
      x: Ieee.Ext;
      fli: LONG INTEGER;
      fc: CARDINAL;
      inv, ov: BOOLEAN;
      fpmode ← m;
      thisTimeExceptions ← Real.NoExceptions;
      x ← Unpack[a];
      [v: fli, invalid: inv, overflow: ov] ← FixExtended[x, fpmode.round];
      IF inv THEN InvalidAndDie[@x];
      IF ov OR fli NOT IN [FIRST[CARDINAL]..LAST[CARDINAL]] THEN {
	Ieee.SetFixOverflow[];
	IF fpmode.traps[fixOverflow] THEN {
	  p: REF Real.Extended ← NEW[Real.Extended ← Ieee.CVExtended[x]];
	  IF SIGNAL Real.RealException[thisTimeExceptions, p] THEN RETURN[LOOPHOLE[p↑.frac, Basics.LongNumber].lowbits];
	  };
	IF NOT ov AND x.det.sign THEN fli ← -fli;
	};
      fc ← LOOPHOLE[fli, Basics.LongNumber].lowbits;
      RETURN[fc];
      };

  SquareReal:  TYPE = RECORD [m2: CARDINAL,
		sign: BOOLEAN, expD2: [0..128), index: [0..32), m1: [0..8)];

	SqRt:  PUBLIC SAFE PROC [a: REAL, m: Mode ← RealOps.DefMode] RETURNS [b:  REAL] = TRUSTED {
	  aFmt: SquareReal;
	  bFmt: SingleReal;
	  x: Ieee.Ext;
	  {
	  fpmode ← m;
	  thisTimeExceptions ← Real.NoExceptions;
	  x ← Unpack[a];
	  SELECT x.det.type FROM
    	nan => IF a = Real.TrappingNaN THEN GOTO Invalid ELSE RETURN[a];
    	infinity => IF m.im = projective OR x.det.sign THEN GOTO Invalid ELSE RETURN[Real.PlusInfinity];
    	zero => RETURN[a];
    	normal => NULL;
    	ENDCASE => ERROR;
	  IF x.det.sign OR NOT Normalized[x.frac.highbits] THEN GOTO Invalid;
	  aFmt ← LOOPHOLE[a, SquareReal];
	  bFmt ← LOOPHOLE[sqGuesses[aFmt.index], SingleReal];
	  bFmt.exp ← bFmt.exp + aFmt.expD2 - 63;
	  b ← LOOPHOLE[bFmt, REAL];
      b ← LOOPHOLE[LOOPHOLE[b + a/b, LONG CARDINAL] - 40000000B, REAL];
	  b ← LOOPHOLE[LOOPHOLE[b + a/b, LONG CARDINAL] - 40000000B, REAL];
	  EXITS
	  Invalid => {
	    x.frac.lc ← Real.SqRtNaN;
	    Ieee.SetInvalidOperation[]; -- Signal invalid operation
	    RETURN[Ieee.Pack[@x]];
	    };
	  };
	  };

    FScale: PUBLIC SAFE PROC [a: REAL, scale: INTEGER, m: Mode ← DefMode] RETURNS [REAL] = TRUSTED {
      x: Ieee.Ext ← Unpack[a];
      SELECT x.det.type FROM
    	nan => IF a # Real.TrappingNaN THEN RETURN[a];
    	infinity, zero => RETURN[a];
    	normal => NULL;
    	ENDCASE => ERROR;
      IF scale > 400 THEN Ieee.SetOverflow[@x];
      IF scale < -400 THEN Ieee.SetOverflow[@x];
      x.exp ← x.exp + scale;
      Ieee.StepTwo[@x];
      RETURN[Ieee.Pack[@x]];
      };
  
    END.
L. Stewart, July 12, 1980  11:13 PM, Rounds changed to return low order bits on RESUME.
L. Stewart, August 12, 1980  12:05 PM, RoundI, RoundC fixed for negative arguments.
August 25, 1980  4:05 PM, LStewart; formatting, shorten Float
June 3, 1982 12:02 pm, L. Stewart, REF Extended in RealException, SqRt and FScale
August 27, 1982 11:30 am, L. Stewart, added TRUSTED