CompilerSingleReal.contract

/*
* CompilerSingleReal.contract
*
* - 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 <cedar/CedarExtra.h>
#include <math.h>

typedef unsigned REAL32;
typedef unsigned INT32;
typedef unsigned CARD32;
typedef int 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𡤏loatInt(i)
 INT32 i;
{
 float retval = ((int) i);
 return (ToREAL32(retval));
};

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

/* RealNeg: PROC [a: REAL32] RETURNS [REAL32]; */
extern REAL32
XR←RealNeg(a)
 REAL32 a;
{
 float retval = -ToSingle(a);
 return (ToREAL32(retval));
};

/*
* RealAbs: PROC [a: REAL32] RETURNS [REAL32]; may re-evaluate arguments
*/
extern REAL32
XR←RealAbs(a)
 REAL32 a;
{
 float retval = (ToSingle(a)>= 0 ? ToSingle(a) : -ToSingle(a));
 return (ToREAL32(retval));
};

/* 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←RaiseError(XR←UnnamedError, 0);
};

/*
* 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(ee, bb);
 e = p; /*down to single precision*/
 return (ToREAL32(e));
};