<<>>
/*
 * CompilerSingleReal.c - Note: compile this module with the switch
 * "-fsingle" The routines in this file implement a portion of the interface
 * between the Cedar compiler and the runtime support routines for the
 * compiled code.  If you are not writing the compiler, loader, makeboot, or
 * the runtime initialization you shouldn't be looking at this file.
 */

/*
 * last edited by Christian Jacobi, March 4, 1988 10:36:46 am PST last edited
 * by Christian Jacobi, August 12, 1988 4:11:53 pm PDT
 */

/*
 * REAL32 is a 32 bit quantity used internally by the Compiler to represent
 * IEEE single precision floating point numbers [the Compiler used untyped
 * operands and defines the type to be used with the operator]. As a
 * consequence, this also prevents the C compiler from converting them to
 * double precision. INT32 and CARD32 are the respective types used
 * internally by the compiler to represent 32 bit sigened or unsgned
 * integers.
 */

#include "CedarExtra.h"
#include <math.h>

typedef unsigned REAL32;
typedef unsigned INT32;
typedef unsigned CARD32;
typedef unsigned BOOLEAN;
#define TRUE 1
#define FALSE 0

/*
 * These macros attempt to do LOOPHOLEs as opposed to C's cast. The
 * difference is that no code is generated for a LOOPHOLE, while a cast can
 * generate code.  This implementation doesn't quite avoid code generation,
 * but it comes close.  Note that this module is compiled with the -fsingle
 * switch to prevent casting floats into doubles.
 */

#define ToSingle(a) *(float *)(&a)    /* single precision float from REAL32 */
#define ToREAL32(a) *(REAL32 *)(&a)    /* REAL32 from a single float */

/* FloatInt: PROC [i: INT32] RETURNS [REAL32]; */
extern          REAL32
XR_FloatInt(i)
    INT32           i;
{
    float           retval = ((int) i);
    return (ToREAL32(retval));
};

/* FloatCard: PROC [c: CARD32] RETURNS [REAL32]; */
extern          REAL32
XR_FloatCard(c)
    CARD32          c;
{
    float           retval = c;
    return (ToREAL32(retval));
};

/* RealNeg: PROC [a: REAL32] RETURNS [REAL32]; */
extern          REAL32
XR_RealNeg(a)
    REAL32          a;
{
    return (a ^ -2147483648);    /* -2147483648 is 20000000000B */
};

/*
 * RealAbs: PROC [a: REAL32] RETURNS [REAL32]; may re-evaluate arguments
 */
extern          REAL32
XR_RealAbs(a)
    REAL32          a;
{
    return ((a << 1) >> 1);
};

/* RealAdd: PROC [a, b: REAL32] RETURNS [REAL32]; */
extern          REAL32
XR_RealAdd(a, b)
    REAL32          a, b;
{
    float           retval = ToSingle(a) + ToSingle(b);
    return (ToREAL32(retval));
};

/*
 * RealSub: PROC [a, b: REAL32] RETURNS [REAL32]; (a-b)
 */
extern          REAL32
XR_RealSub(a, b)
    REAL32          a, b;
{
    float           retval = ToSingle(a) - ToSingle(b);
    return (ToREAL32(retval));
};


/* RealMul: PROC [a, b: REAL32] RETURNS [REAL32]; */
extern          REAL32
XR_RealMul(a, b)
    REAL32          a, b;
{
    float           retval = ToSingle(a) * ToSingle(b);
    return (ToREAL32(retval));
};

/*
 * RealDiv: PROC [a, b: REAL32] RETURNS [REAL32]; (a/b)
 */
extern          REAL32
XR_RealDiv(a, b)
    REAL32          a, b;
{
    float           retval = ToSingle(a) / ToSingle(b);
    return (ToREAL32(retval));
};

/*
 * RealMin: PROC [a, b: REAL32] RETURNS [REAL32]; may re-evaluate arguments
 */
extern          REAL32
XR_RealMin(a, b)
    REAL32          a, b;
{
    float           retval = (ToSingle(a) <= ToSingle(b) ? ToSingle(a) : ToSingle(b));
    return (ToREAL32(retval));
};

/*
 * RealMax: PROC [a, b: REAL32] RETURNS [REAL32]; may re-evaluate arguments
 */
extern          REAL32
XR_RealMax(a, b)
    REAL32          a, b;
{
    float           retval = (ToSingle(a) >= ToSingle(b) ? ToSingle(a) : ToSingle(b));
    return (ToREAL32(retval));
};

/*
 * RealGt: PROC [a, b: REAL32] RETURNS [BOOL]; (a>b)
 */
extern          BOOLEAN
XR_RealGt(a, b)
    REAL32          a, b;
{
    return (ToSingle(a) > ToSingle(b) ? TRUE : FALSE);
};

/*
 * RealGe: PROC [a, b: REAL32] RETURNS [BOOL]; (a>=b)
 */
extern          BOOLEAN
XR_RealGe(a, b)
    REAL32          a, b;
{
    return (ToSingle(a) >= ToSingle(b) ? TRUE : FALSE);
};

/*
 * RealEq: PROC [a, b: REAL32] RETURNS [BOOL]; (a=b)
 */
extern          BOOLEAN
XR_RealEq(a, b)
    REAL32          a, b;
{
    return (ToSingle(a) == ToSingle(b) ? TRUE : FALSE);
};


static void
ErrorUndefined()
{
    /* this is not the right error */
    (void) XR_RaiseArithmeticFault();
};

/*
 * SignedPwr: PROC [base, exp: INT32] RETURNS [INT32];
 */
extern          INT32
XR_SignedPwr(base, exp)
    INT32           base, exp;
{
    int             p = 1;
    int             b = (int) base;
    int             e = (int) exp;
    switch (b) {
    case 0:
        if (e <= 0)
            (void) ErrorUndefined();
        return ((INT32) 0);
    case 1:
        return ((INT32) 1);
    case -1:
        if (e & 1)
            return ((INT32) - 1);
        else
            return ((INT32) 1);
    default:
        break;
    };
    if (e < 0)
        return ((INT32) 0);
    /* invariant: p * b**e = base**exp   */
    while (1) {
        if (e & 1) {
            p *= b;
            e -= 1;
        };
        if (e) {
            b *= b;
            e /= 2;
        } else {
            if (base)
                return ((INT32) p);
            (void) ErrorUndefined();
        };
    };
};


/*
 * UnsignedPwr: PROC [base, exp: CARD32] RETURNS [CARD32];
 */
extern          CARD32
XR_UnsignedPwr(base, exp)
    CARD32          base, exp;
{
    unsigned        p = 1;
    unsigned        b = (unsigned) base;
    unsigned        e = (unsigned) exp;
    /* invariant: p * b**e = base**exp   */
    while (1) {
        if (e & 1) {
            p *= b;
            e -= 1;
        };
        if (e) {
            b *= b;
            e /= 2;
        } else {
            if (base)
                return ((CARD32) p);
            (void) ErrorUndefined();
        };
    };
};

/*
 * RealPwr: PROC [base, exp: REAL32] RETURNS [REAL32];
 */
extern          REAL32
XR_RealPwr(base, exp)
    REAL32          base, exp;
{
    float           e = ToSingle(exp);
    float           b = ToSingle(base);
    double          ee = e;
    double          bb = b;
    double          p = pow(bb, ee);
    e = p;            /* down to single precision */
    return (ToREAL32(e));
};