
    <<IeeePack.mesa - Ieee Floating Point Package for compiler (Ieee + IeeeIOA + IeeeUtil)>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<Satterthwaite, April 16, 1986 3:10:48 pm PST>>
        <<Maxwell, August 11, 1983 8:36 am>>
        <<Russ Atkinson (RRA) March 6, 1985 10:29:58 pm PST>>

    DIRECTORY
        Basics: TYPE USING [BITAND, BITOR, BITSHIFT, BITXOR, LongMult, LongNumber],
        Real: TYPE USING [Exception, ExceptionFlags, Extended, MinusInfinity, MinusZero, Mode, NoExceptions, NumberType, PlusInfinity, 
        PlusZero, TrapNonTrappingNaN, TrapTrappingNaN];

    IeeePack: PROGRAM
        IMPORTS Basics
        EXPORTS Real = {
        OPEN Basics, Real;

    RealException: PUBLIC SIGNAL[flags: ExceptionFlags] = CODE;

    <<from Ieee.Mesa>>

    Details: TYPE = MACHINE DEPENDENT RECORD[
        sign: BOOL,
        sticky: BOOL,
        blank: [0..7777b],
        type: Real.NumberType];

    Ext: TYPE = RECORD[
        det: Details,
        exp: INTEGER,
        frac: LongNumber];

    <<constants>>

    HiBit: CARDINAL = 100000b;
    ExponentBias: INTEGER = 127;
    ExponentMask: INTEGER = 077600b;
    ExponentShift: INTEGER = 7;
    HiFractionMask: INTEGER = 177b;
    FractionShift: INTEGER = 8;
    LeastSignificandBit: INTEGER = 0400b;
    HiddenBit: CARDINAL = 100000b;
    StickyBits: CARDINAL = 77b;
    HalfLC: LONG CARDINAL = 20000000000b;

    SignBit: CARDINAL = 100000b;
    ExpSingleMax: INTEGER = 127;
    ExpSingleMin: INTEGER = -126;
    DenormalizedExponent: INTEGER = -127;
    NaNExponent: INTEGER = 128;

    BiasAdjust: INTEGER = 192;

    <<global variables>>

    fpmode: Mode = [nm: warning, round: rn];
    enableFlags: ExceptionFlags = [invalidOperation: TRUE, divisionByZero: TRUE, overflow: TRUE];
    thisTimeExceptions: ExceptionFlags;

    LN: PROC[r: LONG UNSPECIFIED] RETURNS[LongNumber] = INLINE {
        RETURN[LOOPHOLE[r, LongNumber]]};

    BitOn: PROC[a, b: UNSPECIFIED] RETURNS[BOOL] = INLINE {
        RETURN[BITAND[a, b]#0]};

    Normalized: PROC[g: INTEGER] RETURNS[BOOL] = INLINE {
        RETURN[BITAND[g, HiddenBit]#0]};

    <<Add with Carry>>

    ADC3: PROC[a, b, c: CARDINAL] RETURNS [CARDINAL, CARDINAL] = INLINE {
        s: LongNumber;
        s.lc _ a.LONG+b.LONG+c.LONG;
        RETURN[s.highbits, s.lowbits]};

    <<from IeeeIOA>>

    PowTen: TYPE = RECORD[
        f: LONG CARDINAL,
        e: INTEGER];
    TenTable: TYPE = RECORD[
        tens: ARRAY [0..13] OF PowTen,
        t26, t39: PowTen];
    posTable: TenTable = [
        tens: [
            [ 20000000000b,  0], [ 24000000000b,  3],
            [ 31000000000b,  6], [ 37200000000b,  9],
            [ 23420000000b, 13], [ 30324000000b, 16],
            [ 36411000000b, 19], [ 23045500000b, 23],
            [ 27657020000b, 26], [ 35632624000b, 29],
            [ 22500574400b, 33], [ 27220733500b, 36],
            [ 35065122420b, 39], [ 22141163452b, 43]],
        t26: [24533722672b, 86],
        t39: [27405037645b, 129]];
    negTable: TenTable = [
        tens: [
            [ 20000000000b,   0], [ 31463146315b,  -4],
            [ 24365605075b,  -7], [ 20304467230b, -10],
            [ 32155613531b, -14], [ 24761326107b, -17],
            [ 20615736406b, -20], [ 32657712326b, -24],
            [ 25363073422b, -27], [ 21134057501b, -30],
            [ 33371577317b, -34], [ 25772777414b, -37],
            [ 21457146011b, -40], [ 34113411502b, -44]],
        t26: [30604403045b, -87],
        t39: [25616276613b, -130]];

    MulExtended: PROC[x, y: Ext] RETURNS[z: Ext] = {
        hi, lo: LongNumber;
        z.exp _ x.exp+y.exp+1;
        z.det.sign _ x.det.sign#y.det.sign;
        z.det.type _ normal;
        z.det.sticky _ x.det.sticky OR y.det.sticky;
        [hi, lo] _ Mul32[x.frac, y.frac];
        <<normalize 64>>
        WHILE NOT BitOn[hi.highbits, HiBit] DO
            hi.lc _ hi.lc+hi.lc;
            IF BitOn[lo.highbits, HiBit] THEN hi.lowbits _ BITOR[hi.lowbits, 1];
            lo.lc _ lo.lc+lo.lc;
            z.exp _ z.exp-1;
            ENDLOOP;
        z.frac _ hi;
        <<Round to 32 bits.>>
        IF lo.lc>HalfLC OR (lo.lc=HalfLC AND BitOn[z.frac.lowbits, 1]) THEN {
            <<Overflow>>
            z.frac.lc _ z.frac.lc+1;
            IF z.frac.lc<hi.lc THEN {
                z.frac.lc _ RShift1in1[z.frac.lc];
                z.exp _ z.exp+1};
            };
        IF lo.lc#0 THEN z.det.sticky _ TRUE};

    Scale: PROC[x: Ext, exp10: INTEGER] RETURNS[y: Ext] = {
        table: TenTable;
        mul: PowTen;
        big: BOOL;
        IF exp10=0 THEN RETURN [x];
        big _ exp10<0;
        table _ IF big THEN negTable ELSE posTable;
        exp10 _ ABS[exp10];
        SELECT exp10 FROM
            IN [1..13] => mul _ table.tens[exp10];
            IN (13..26) => {
                x _ MulExtended[x, CVExt[table.tens[13]]];
                mul _ table.tens[exp10-13]};
            =26 => mul _ table.t26;
            IN (26..39) => {
                x _ MulExtended[x, CVExt[table.t26]];
                mul _ table.tens[exp10-26]};
            =39 => mul _ table.t39;
            IN (39..52] => {
                x _ MulExtended[x, CVExt[table.t39]];
                mul _ table.tens[exp10-39]};
            ENDCASE => {
                WHILE exp10>52 DO
                    x _ MulExtended[x, CVExt[table.t39]];
                    exp10 _ exp10-39;
                    ENDLOOP;
                RETURN[Scale[x, IF big THEN -exp10 ELSE exp10]]};
        y _ CVExt[mul];
        y _ MulExtended[x, y]};

    CVExt: PROC[t: PowTen] RETURNS[y: Ext] = {
        y.det.sticky _ y.det.sign _ FALSE;
        y.det.type _ normal;
        y.frac.lc _ t.f;
        y.exp _ t.e};

    PairToReal: PUBLIC PROC[fr: LONG INTEGER, exp10: INTEGER] RETURNS[REAL] = {
        y: Ext;
        <<or: RoundingMode _ fpmode.round;>>
        <<fpmode.round _ rn;>>
        thisTimeExceptions _ NoExceptions;
        IF fr=0 THEN RETURN[PlusZero];
        y.exp _ 31;
        y.det.sign _ fr<0;
        y.det.sticky _ FALSE;
        y.det.type _ normal;
        y.frac.li _ IF y.det.sign THEN -fr ELSE fr;
        PostNormalize[@y];
        y _ Scale[y, exp10];
        StepTwo[@y];
        <<fpmode.round _ or;>>
        RETURN[Pack[@y]]};

    <<from IeeeFloatA (adapted)>>

    RealToExtended: PUBLIC PROC[a: REAL] RETURNS[Real.Extended] = {
        ext: Ext = Unpack[a];
        RETURN[[type: ext.det.type, sign: ext.det.sign, exp: ext.exp, frac: ext.frac.lc]]};

    ExtendedToReal: PUBLIC PROC[e: Real.Extended] RETURNS[REAL] = {
        ext: Ext _ [
            det: [sign: e.sign, sticky: FALSE, blank: 0, type: e.type],
            exp: e.exp, frac: [lc[e.frac]]];
        RETURN[Pack[@ext]]};


    Negate: PUBLIC PROC[a: REAL] RETURNS[REAL] = {
        IF LN[a] = LN[PlusZero] THEN RETURN[PlusZero];
        <<Negate a>>
        LOOPHOLE[a, LongNumber].highbits _ BITXOR[LN[a].highbits, SignBit];
        RETURN[a]};

    Abs: PUBLIC PROC[a: REAL] RETURNS[REAL] = {
        RETURN[IF BitOn[LN[a].highbits, SignBit] THEN Negate[a] ELSE a]};

    <<from IEEEUtil>>

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

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

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

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

    <<Separate the packed REAL into its component elements>>

    Unpack: PUBLIC PROC[r: REAL] RETURNS[z: Ext] = {
        z.det.sticky _ FALSE;
        z.det.sign _ BitOn[LN[r].highbits, HiBit]; -- first r.j. the exponent
        z.exp _ Basics.BITSHIFT[
            Basics.BITAND[LN[r].highbits, ExponentMask], -ExponentShift];
        z.exp _ z.exp - ExponentBias;
        z.det.type _ normal;
        z.frac.li _ LN[r].li;
        z.frac.highbits _ Basics.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 _ Basics.BITOR[HiddenBit, z.frac.highbits]};
        };

    <<Stuff the components back into the packed REAL.>>

    Pack: PROC[z: POINTER TO Ext] RETURNS[r: REAL]  = {
        trap: BOOL _ FALSE;
        i: Exception;
        IF thisTimeExceptions#NoExceptions THEN {
            <<Possible typo in standard here!!!>>
            IF thisTimeExceptions[invalidOperation] THEN {
                z.det.type _ nan;
                IF z.frac.lc=0 THEN z.frac.lc _ TrapNonTrappingNaN};
            FOR i IN Exception DO
                trap _ trap OR (enableFlags[i] AND thisTimeExceptions[i]);
                ENDLOOP ;
            IF trap THEN
                SIGNAL RealException[flags: thisTimeExceptions];
            FixupProcedure[z]};
        RETURN[UsualPack[z^]]};

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



    FixupProcedure: PROC[vp: POINTER TO Ext] = {
        IF thisTimeExceptions[underflow] THEN {
            DeNormalize[vp, vp.exp-ExpSingleMin];
            vp.exp _ DenormalizedExponent};
        IF thisTimeExceptions[overflow] THEN
            vp.det.type _ infinity;
        };

    Round: PROC[z: POINTER TO Ext] = {
        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: PROC [g: INTEGER] RETURNS [INTEGER] = {
            <<StickyBits are the set used for rounding to 24 bits>>
            s: BOOL _ BitOn[g, StickyBits] OR z.det.sticky;
            <<Should flush these constants>>
            g _ BITSHIFT[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[];
        BEGIN
        SELECT fpmode.round FROM
            rn => {
                IF z.det.sign THEN grs _ 8-grs;
                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};
            };
        END};

    RShift1in1: PROC[z: LONG UNSPECIFIED] RETURNS[LONG UNSPECIFIED] = {
        vl: LongNumber;
        vl.lc _ z;
        vl.lowbits _ BITSHIFT[vl.lowbits, -1];
        IF BitOn[vl.highbits, 1] THEN vl.lowbits _ BITOR[vl.lowbits, HiBit];
        vl.highbits _ BITOR[HiddenBit, BITSHIFT[vl.highbits, -1]];
        RETURN [vl.lc]};

    LShift: PROC[z: LONG UNSPECIFIED] RETURNS[LONG UNSPECIFIED] = {
        vl: LongNumber;
        vl.lc _ z;
        vl.highbits _ BITSHIFT[vl.highbits, 1];
        IF BitOn[vl.lowbits, HiBit] THEN vl.highbits _ BITOR[vl.highbits, 1];
        vl.lowbits _ BITSHIFT[vl.lowbits, 1];
        RETURN [vl.lc]};

    StepTwo: PROC[z: POINTER TO Ext] = {
        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]};
        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: PROC[x, y: LongNumber] RETURNS[LongNumber, LongNumber] = {
        hi, lo, t1, t2: LongNumber;
        cy: CARDINAL;
        lo.lc _ LongMult[x.lowbits, y.lowbits];
        hi.lc _ LongMult[x.highbits, y.highbits];
        t1.lc _ LongMult[x.highbits, y.lowbits];
        t2.lc _ LongMult[x.lowbits, y.highbits];
        [cy, lo.highbits] _ 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: PROC[z: POINTER TO Ext] = {
        IF z.frac.lc=0 THEN ERROR;
        WHILE BITAND[z.frac.highbits, HiddenBit]=0 DO
            z.frac.lc _ LShift[z.frac.lc];
            z.exp _ z.exp-1;
            ENDLOOP;
        };

    <<positive count is left shift, negative is right shift>>

    LongShift: PROC[z: LONG UNSPECIFIED, count: INTEGER] RETURNS[LONG UNSPECIFIED] = {
        xl, vl: LongNumber;
        vl.lc _ z;
        SELECT count FROM
            NOT IN (-32..32) => RETURN [0];
            0 => RETURN [vl.lc];
            IN [16..32) => {
                xl.highbits _ BITSHIFT[vl.lowbits,count-16];
                xl.lowbits _ 0};
            IN (0..16) => {
                xl.highbits _ BITSHIFT[vl.highbits, count] + BITSHIFT[vl.lowbits,count-16];
                xl.lowbits _ BITSHIFT[vl.lowbits, count]};
            IN (-16..0) => {
                xl.highbits _ BITSHIFT[vl.highbits, count];
                xl.lowbits _ BITSHIFT[vl.lowbits, count] + BITSHIFT[vl.highbits,count+16]};
            IN (-32..-16] => {
                xl.highbits _ 0;
                xl.lowbits _ BITSHIFT[vl.highbits,count+16]};
            ENDCASE => ERROR;
        RETURN[xl.lc]};

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

    DeNormalize: PROC[z: POINTER TO Ext, count: INTEGER] = {
        sMask: ARRAY [1..16) OF CARDINAL = [
            1b, 3b, 7b, 17b, 37b, 77b, 177b, 377b, 777b, 1777b, 3777b, 7777b, 17777b, 37777b, 77777b];
        <<Mask off everything but the bits contributing to S, then set or clear S in the result.>>
        IF count>0 THEN ERROR;
        IF count=0 THEN RETURN;
        count _ -count;
        z.det.sticky _ SELECT count FROM
            =16 => z.frac.lowbits#0,
            IN [1..16) => BitOn[z.frac.lowbits, sMask[count]],
            IN (16..32) => z.frac.lowbits#0 OR BitOn[z.frac.highbits, sMask[count-16]],
            ENDCASE => z.frac.lc#0;
        z.frac.lc _ LongShift[z.frac.lc, -count]};

    }.

