/*
 * 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_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;
{
	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));
};
	

   b  
CompilerSingleReal.contract
Copyright س 1991 by Xerox Corporation.  All rights reserved.

 ‌ت `  –(cedarcode) style•NewlineDelimiter
™ ™Jڑœ
دeœ1™<J™ —Jڑœق,کق,Jک — …—    `  "  