-- IeeeUtil.mesa
-- Last Modified: Stewart, August 27, 1982 11:33 am
-- Last Modified: Paul Rovner, May 4, 1983 9:57 am
-- IEEE float utilities
-- Last Edited by: Levin, August 8, 1983 4:35 pm

DIRECTORY
  Basics USING [LongMult, LongNumber],
  Ieee,
  PrincOps,
  PrincOpsUtils,
  Real,
  RealOps USING [DefMode, Mode];

IeeeUtil: CEDAR PROGRAM IMPORTS Ieee, PrincOpsUtils, Real EXPORTS Ieee =
  BEGIN OPEN Ieee, Real;

  -- global variables
  fpmode: PUBLIC RealOps.Mode _ RealOps.DefMode;
  thisTimeExceptions: PUBLIC Real.ExceptionFlags _ Real.NoExceptions;
  stickyFlags: PUBLIC Real.ExceptionFlags _ Real.NoExceptions;

  SetInexactResult: PUBLIC PROC = {thisTimeExceptions[inexactResult] _ TRUE; };

  SetInvalidOperation: PUBLIC PROC = {
    thisTimeExceptions[invalidOperation] _ TRUE; };

  SetDivisionByZero: PUBLIC PROC = {thisTimeExceptions[divisionByZero] _ TRUE; };

  SetUnderflow: PUBLIC PROC [z: POINTER TO Ext] = {
    thisTimeExceptions[underflow] _ TRUE; };

  SetOverflow: PUBLIC PROC [z: POINTER TO Ext] = {
    thisTimeExceptions[overflow] _ TRUE; };

  SetFixOverflow: PUBLIC PROC = {
    thisTimeExceptions[fixOverflow] _ TRUE; stickyFlags[fixOverflow] _ TRUE; };

  -- Separate the packed REAL into its component elements

  Unpack: PUBLIC PROC [r: REAL] RETURNS [z: Ext] = TRUSTED {
    z.det.sticky _ FALSE;
    z.det.sign _ BitOn[LN[r].highbits, HiBit]; -- first r.j. the exponent
    z.exp _ PrincOpsUtils.BITSHIFT[
      PrincOpsUtils.BITAND[LN[r].highbits, ExponentMask], -ExponentShift];
    z.exp _ z.exp - ExponentBias;
    z.det.type _ normal;
    z.frac.li _ LN[r].li;
    z.frac.highbits _ PrincOpsUtils.BITAND[HiFractionMask, z.frac.highbits];
    SELECT z.exp FROM
      = DenormalizedExponent => {
	-- denormalized or zero
	IF z.frac.li = 0 THEN z.det.type _ zero
	ELSE {
	  z.exp _ ExpSingleMin;
	  z.frac.li _ LongShift[z.frac.li, FractionShift];
	  IF fpmode.nm = normalizing THEN PostNormalize[@z];
	  };
	};
      = NaNExponent => {
	-- infinity or nan
	IF z.frac.li = 0 THEN z.det.type _ infinity
	ELSE {
	  z.det.type _ nan;
	  IF z.frac.lc = Real.TrapTrappingNaN THEN SetInvalidOperation[];
	  };
	};
      ENDCASE => {
	z.frac.li _ LongShift[z.frac.li, FractionShift];
	z.frac.highbits _ PrincOpsUtils.BITOR[HiddenBit, z.frac.highbits];
	};
    };

  -- Stuff the components back into the packed REAL.

  Pack: PUBLIC PROC [z: POINTER TO Ext] RETURNS [r: REAL] = TRUSTED {
    trap: BOOLEAN _ FALSE;
    p: REF Extended _ NIL;
    clientFix: BOOL;
    i: Exception;
    IF thisTimeExceptions # NoExceptions THEN {
      -- Possible typo in standard here!!!
      -- IF fpmode.round=rm OR fpmode.round=rp THEN {
      -- IF NOT fpmode.traps[overflow] THEN thisTimeExceptions[overflow] _ FALSE;
      -- IF NOT fpmode.traps[underflow] THEN thisTimeExceptions[underflow] _ FALSE;
      -- };
      IF thisTimeExceptions[invalidOperation] THEN {
	z.det.type _ nan; IF z.frac.lc = 0 THEN z.frac.lc _ TrapNonTrappingNaN; };
      FOR i IN Exception DO
	stickyFlags[i] _ stickyFlags[i] OR thisTimeExceptions[i];
	trap _ trap OR (fpmode.traps[i] AND thisTimeExceptions[i]);
	ENDLOOP;
      IF trap THEN {
	p _ NEW[Extended _ CVExtended[z^]];
	clientFix _ SIGNAL Real.RealException[flags: thisTimeExceptions, vp: p];
	IF NOT clientFix THEN FixupProcedure[z] ELSE CFExtended[p, z];
	}
      ELSE FixupProcedure[z];
      };
    RETURN[UsualPack[z^]];
    };

  UsualPack: PUBLIC PROC [z: Ext] RETURNS [REAL] = TRUSTED {
    SELECT z.det.type FROM
      zero => RETURN[IF z.det.sign THEN Real.MinusZero ELSE Real.PlusZero];
      infinity =>
	RETURN[IF z.det.sign THEN Real.MinusInfinity ELSE Real.PlusInfinity];
      nan => z.exp _ NaNExponent;
      ENDCASE => z.frac.li _ LongShift[z.frac.li, -FractionShift];
    -- clear hidden bit
    z.frac.highbits _ PrincOpsUtils.BITAND[z.frac.highbits, HiFractionMask];
    IF z.exp NOT IN [-127..128] THEN ERROR;
    z.exp _ PrincOpsUtils.BITSHIFT[z.exp + ExponentBias, ExponentShift];
    z.frac.highbits _ PrincOpsUtils.BITOR[z.frac.highbits, z.exp];
    IF z.det.sign THEN z.frac.highbits _ PrincOpsUtils.BITOR[z.frac.highbits, SignBit];
    RETURN[LOOPHOLE[z.frac.li, REAL]];
    };

  FixupProcedure: PUBLIC PROC [vp: POINTER TO Ext] = TRUSTED {
    IF thisTimeExceptions[underflow] THEN {
      DeNormalize[vp, vp.exp - ExpSingleMin];
      vp.exp _ DenormalizedExponent;
      Round[vp];
      IF vp.exp # DenormalizedExponent THEN {
	vp.frac.lc _ RShift[vp.frac.lc]; vp.exp _ DenormalizedExponent; };
      };
    IF thisTimeExceptions[overflow] THEN {
      stickyFlags[inexactResult] _ TRUE;
      SELECT fpmode.round FROM
	rn, rz => GOTO SignTest;
	rp => IF NOT vp.det.sign THEN GOTO SignTest;
	rm => IF vp.det.sign THEN GOTO SignTest;
	ENDCASE => ERROR;
      IF Ieee.Normalized[vp.frac.highbits] THEN vp.frac.lc _ LargestSignificand;
      vp.exp _ ExpSingleMax;
      EXITS SignTest => vp.det.type _ infinity;
      };
    };

  Round: PUBLIC PROC [z: POINTER TO Ext] = TRUSTED {
    temp: LONG CARDINAL;
    -- A 32 bit extended is considered to have its hidden bit as bit 0, significand as the next 29 bits, then G, then R, then S as a separate boolean.  GRS computs the 3 bit number formed by the concatenation of G, R, and IF S THEN 1 ELSE 0.
    GRS: PUBLIC PROC [g: CARDINAL] RETURNS [INTEGER] = TRUSTED {
      -- StickyBits are the set used for rounding to 24 bits
      s: BOOLEAN _ BitOn[g, StickyBits] OR z.det.sticky;
      -- Should flush these constants
      g _ PrincOpsUtils.BITSHIFT[PrincOpsUtils.BITAND[g, 300B], -5];
      IF s THEN g _ g + 1;
      RETURN[g];
      }; -- The fraction should be normalized here!
    grs: INTEGER _ GRS[z.frac.lowbits];
    IF grs = 0 THEN RETURN;
    SetInexactResult[];
    {
    SELECT fpmode.round FROM
      rn =>
	IF grs > 4 OR (grs = 4 AND BitOn[z.frac.lowbits, LeastSignificandBit])
	  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 => {
	temp _ z.frac.lc;
	z.frac.lc _ z.frac.lc + LeastSignificandBit;
	IF z.frac.lc <= temp THEN {
	  -- better overflow detect!
	  z.frac.li _ RShift1in1[z.frac.li];
	  z.exp _ z.exp + 1;
	  };
	};
    };
    };

  RShift1in1: PUBLIC PROC [z: LONG UNSPECIFIED] RETURNS [LONG UNSPECIFIED] = TRUSTED {
    vl: Basics.LongNumber;
    vl.lc _ z;
    vl.lc _ vl.lc/2;
    vl.highbits _ PrincOpsUtils.BITOR[HiddenBit, vl.highbits];
    RETURN[vl.lc];
    };

  NormalType: PUBLIC PROC [x, y: Details] RETURNS [INTEGER] = TRUSTED {
    RETURN[(LOOPHOLE[x.type, INTEGER]*2) + LOOPHOLE[y.type, INTEGER]]; };

  RShift: PUBLIC PROC [z: LONG UNSPECIFIED] RETURNS [LONG UNSPECIFIED] = TRUSTED {
    z _ LOOPHOLE[z, LONG CARDINAL]/2; RETURN[z]; };

  LShift: PUBLIC PROC [z: LONG UNSPECIFIED] RETURNS [LONG UNSPECIFIED] = TRUSTED {
    z _ LOOPHOLE[z, LONG CARDINAL]*2; RETURN[z]; };

  StepTwo: PUBLIC PROC [z: POINTER TO Ext] = TRUSTED {
    IF z.det.type # normal THEN RETURN;
    IF z.exp <= ExpSingleMin THEN {
      IF z.exp < ExpSingleMin OR (NOT Normalized[z.frac.highbits]) THEN
	SetUnderflow[z];
      };
    IF NOT thisTimeExceptions[underflow] THEN Round[z];
    IF (NOT Normalized[z.frac.highbits]) AND z.exp # DenormalizedExponent AND
      (NOT thisTimeExceptions[underflow]) THEN SetInvalidOperation[]
    ELSE IF z.exp > ExpSingleMax THEN SetOverflow[z];
    };

  Mul32: PUBLIC PROC [x, y: Basics.LongNumber]
    RETURNS [Basics.LongNumber, Basics.LongNumber] = TRUSTED {
    hi, lo, t1, t2: Basics.LongNumber;
    cy: CARDINAL;
    lo.lc _ Basics.LongMult[x.lowbits, y.lowbits];
    hi.lc _ Basics.LongMult[x.highbits, y.highbits];
    t1.lc _ Basics.LongMult[x.highbits, y.lowbits];
    t2.lc _ Basics.LongMult[x.lowbits, y.highbits];
    [cy, lo.highbits] _ Ieee.ADC3[lo.highbits, t1.lowbits, t2.lowbits];
    hi.lc _ hi.lc + t1.highbits + t2.highbits + cy;
    RETURN[hi, lo];
    };

  -- Post Normalize.  S does not participate

  PostNormalize: PUBLIC PROC [z: POINTER TO Ext] = TRUSTED {
    IF z.frac.lc = 0 THEN ERROR;
    WHILE NOT Ieee.BitOn[z.frac.highbits, HiddenBit] DO
      z.frac.lc _ LShift[z.frac.lc]; z.exp _ z.exp - 1; ENDLOOP;
    };

  -- positive count is left shift, negative is right shift

  LongShift: PUBLIC PROC [z: LONG UNSPECIFIED, count: INTEGER]
    RETURNS [LONG UNSPECIFIED] = TRUSTED {
    vl: Basics.LongNumber;
    vl.lc _ z;
    IF count >= 0 THEN THROUGH [0..count) DO vl.lc _ vl.lc*2; ENDLOOP
    ELSE THROUGH (count..0] DO vl.lc _ vl.lc/2; ENDLOOP;
    RETURN[vl.lc];
    };

  -- DeNormalize is much like LongShift, except that it maintains the sticky bits on the right. And it only shifts right.

  DeNormalize: PUBLIC PROC [z: POINTER TO Ext, count: INTEGER] = TRUSTED {
    b: BOOLEAN _ FALSE;
    IF count > 0 THEN ERROR;
    THROUGH (count..0] DO
      b _ b OR BitOn[z.frac.lowbits, 1]; z.frac.lc _ z.frac.lc/2; ENDLOOP;
    IF b OR z.det.sticky THEN {
      z.frac.lowbits _ PrincOpsUtils.BITOR[z.frac.lowbits, 1]; z.det.sticky _ FALSE; };
    };

  CVExtended: PUBLIC PROC [z: Ieee.Ext] RETURNS [Real.Extended] = TRUSTED {
    RETURN[[type: z.det.type, sign: z.det.sign, exp: z.exp, frac: z.frac.lc]];
    };

  CFExtended: PUBLIC PROC [zz: REF Real.Extended, z: POINTER TO Ieee.Ext] =
    TRUSTED {
    z.frac.lc _ zz.frac;
    z.exp _ zz.exp;
    z.det.sign _ zz.sign;
    z.det.type _ zz.type;
    z.det.sticky _ TRUE;
    };

  InitIeee: PUBLIC PROC = TRUSTED {
    -- This will get the globals.
    IF Real.Microcode THEN [] _ Ieee.MicroSticky[0]; -- disable uCode IR trap
    };

  END.
L. Stewart July 5, 1980  3:29 PM Bug fix in rounding
L. Stewart July 6, 1980  12:30 PM Bug fix in Denormalize, added InitIeee
L. Stewart July 6, 1980  4:20 PM added microsticky
L. Stewart July 8, 1980  5:00 PM RealOps
August 25, 1980  10:25 AM, L. Stewart; fix to Denormalize, formatting
August 25, 1980  5:09 PM, L. Stewart; smaller and slower
 4-Feb-81 18:51:47, L. Stewart, NonTrappingNaN -> TrapNonTrappingNaNL
 June 3, 1982 11:39 am, L. Stewart, REF Extended
 August 27, 1982 1:00 pm, L. Stewart, CEDAR & TRUSTED