-- JaMMathImpl.mesa
-- Original version by John Warnock, February 27, 1979
-- Last changed by Bill Paxton, December 19, 1980 9:35 AM
-- Last changed by Doug Wyatt, 7-Nov-81 14:15:57
-- Last changed by McGregor, September 10, 1982 11:17 am

DIRECTORY
JaMBasic USING [Object],
JaMInternal USING [Frame],
JaMOps USING [Bug, Compare, Error, Install, InstallReason, MakeName, Pop,
PopBoolean, PopInteger, PopReal, Push, PushBoolean, PushInteger, PushReal,
rangechk, RegisterExplicit, StringCompare, typechk],
Inline USING [BITAND, BITNOT, BITOR, BITSHIFT, BITXOR, LongNumber],
Real USING [FAdd, FDiv, Fix, Float, FMul, FSub, RealException],
RealFns USING [ArcTanDeg, CosDeg, Log, Power, SinDeg, SqRt];

JaMMathImpl: PROGRAM
IMPORTS JaMOps, Inline, Real, RealFns = {
OPEN JaMOps, JaMInternal, JaMBasic;

-- Globals

overflow: name Object;

-- Math operations

Add: PUBLIC PROC[a,b: Object] RETURNS[Object] = {
ENABLE Real.RealException => CHECKED {GOTO Overflow};
WITH a:a SELECT FROM
integer => WITH b:b SELECT FROM
integer => { i,j,k: LONG INTEGER;
i ← a.ivalue; j ← b.ivalue; k ← i + j;
 IF (i<0)#(j<0) OR (i<0)=(k<0) THEN RETURN[[L,integer[k]]]
 ELSE RETURN[[L,real[Real.FAdd[i,j]]]] };
real => RETURN[[L,real[Real.FAdd[a.ivalue,b.rvalue]]]];
ENDCASE;
real => WITH b:b SELECT FROM
integer => RETURN[[L,real[Real.FAdd[a.rvalue,b.ivalue]]]];
real => RETURN[[L,real[Real.FAdd[a.rvalue,b.rvalue]]]];
ENDCASE;
ENDCASE;
ERROR Error[typechk];
EXITS Overflow => ERROR Error[overflow];
};

Sub: PUBLIC PROC[a,b: Object] RETURNS[Object] = {
ENABLE Real.RealException => CHECKED {GOTO Overflow};
WITH a:a SELECT FROM
integer => WITH b:b SELECT FROM
integer => { i,j,k: LONG INTEGER;
i ← a.ivalue; j ← b.ivalue; k ← i - j;
 IF (i<0)=(j<0) OR (i<0)=(k<0) THEN RETURN[[L,integer[k]]]
 ELSE RETURN[[L,real[Real.FSub[i,j]]]] };
real => RETURN[[L,real[Real.FSub[a.ivalue,b.rvalue]]]];
ENDCASE;
real => WITH b:b SELECT FROM
integer => RETURN[[L,real[Real.FSub[a.rvalue,b.ivalue]]]];
real => RETURN[[L,real[Real.FSub[a.rvalue,b.rvalue]]]];
ENDCASE;
ENDCASE;
ERROR Error[typechk];
EXITS Overflow => ERROR Error[overflow];
};

Mul: PUBLIC PROC[a,b: Object] RETURNS[Object] = {
ENABLE Real.RealException => CHECKED {GOTO Overflow};
WITH a:a SELECT FROM
integer => WITH b:b SELECT FROM
integer => { r: REAL ← Real.FMul[a.ivalue,b.ivalue];
IF r IN[FIRST[LONG INTEGER]..LAST[LONG INTEGER]]
 THEN RETURN[[L,integer[Real.Fix[r]]]]
 ELSE RETURN[[L,real[r]]] };
real => RETURN[[L,real[Real.FMul[a.ivalue,b.rvalue]]]];
ENDCASE;
real => WITH b:b SELECT FROM
integer => RETURN[[L,real[Real.FMul[a.rvalue,b.ivalue]]]];
real => RETURN[[L,real[Real.FMul[a.rvalue,b.rvalue]]]];
ENDCASE;
ENDCASE;
ERROR Error[typechk];
EXITS Overflow => ERROR Error[overflow];
};

Div: PUBLIC PROC[a,b: Object] RETURNS[Object] = {
ENABLE Real.RealException => CHECKED {GOTO Overflow};
WITH a:a SELECT FROM
integer => WITH b:b SELECT FROM
integer => IF b.ivalue=0 THEN GOTO Overflow
ELSE RETURN[[L,integer[a.ivalue/b.ivalue]]];
real => RETURN[[L,real[Real.FDiv[a.ivalue,b.rvalue]]]];
ENDCASE;
real => WITH b:b SELECT FROM
integer => RETURN[[L,real[Real.FDiv[a.rvalue,b.ivalue]]]];
real => RETURN[[L,real[Real.FDiv[a.rvalue,b.rvalue]]]];
ENDCASE;
ENDCASE;
ERROR Error[typechk];
EXITS Overflow => ERROR Error[overflow];
};

IDiv: PUBLIC PROC[a,b: Object] RETURNS[Object] = {
WITH a:a SELECT FROM
integer => WITH b:b SELECT FROM
integer => IF b.ivalue=0 THEN ERROR Error[overflow]
ELSE RETURN[[L,integer[a.ivalue/b.ivalue]]];
ENDCASE;
ENDCASE;
ERROR Error[typechk];
};

RDiv: PUBLIC PROC[a,b: Object] RETURNS[Object] = {
ENABLE Real.RealException => CHECKED {GOTO Overflow};
WITH a:a SELECT FROM
integer => WITH b:b SELECT FROM
integer => RETURN[[L,real[Real.FDiv[a.ivalue,b.ivalue]]]];
real => RETURN[[L,real[Real.FDiv[a.ivalue,b.rvalue]]]];
ENDCASE;
real => WITH b:b SELECT FROM
integer => RETURN[[L,real[Real.FDiv[a.rvalue,b.ivalue]]]];
real => RETURN[[L,real[Real.FDiv[a.rvalue,b.rvalue]]]];
ENDCASE;
ENDCASE;
ERROR Error[typechk];
EXITS Overflow => ERROR Error[overflow];
};

Neg: PUBLIC PROC[a: Object] RETURNS[Object] = {
ENABLE Real.RealException => CHECKED {GOTO Overflow};
WITH a:a SELECT FROM
integer => IF a.ivalue#FIRST[LONG INTEGER]
THEN RETURN[[L,integer[-a.ivalue]]]
ELSE RETURN[[L,real[-Real.Float[a.ivalue]]]];
real => RETURN[[L,real[-a.rvalue]]];
ENDCASE;
ERROR Error[typechk];
EXITS Overflow => ERROR Error[overflow];
};

Eq: PUBLIC PROC[a,b: Object] RETURNS[BOOLEAN] = {
SELECT Compare[a,b] FROM
F => RETURN[FALSE];
T => RETURN[TRUE];
nil => ERROR Error[typechk];
ENDCASE => ERROR Bug;
};

Lt: PUBLIC PROC[a,b: Object] RETURNS[BOOLEAN] = {
WITH a:a SELECT FROM
integer => WITH b:b SELECT FROM
integer => RETURN[a.ivalue<b.ivalue];
real => RETURN[a.ivalue<b.rvalue];
ENDCASE;
real => WITH b:b SELECT FROM
integer => RETURN[a.rvalue<b.ivalue];
real => RETURN[a.rvalue<b.rvalue];
ENDCASE;
string => WITH b:b SELECT FROM
string => RETURN[StringCompare[a,b]<0];
ENDCASE;
ENDCASE;
ERROR Error[typechk];
};

Gt: PUBLIC PROC[a,b: Object] RETURNS[BOOLEAN] = {
WITH a:a SELECT FROM
integer => WITH b:b SELECT FROM
integer => RETURN[a.ivalue>b.ivalue];
real => RETURN[a.ivalue>b.rvalue];
ENDCASE;
real => WITH b:b SELECT FROM
integer => RETURN[a.rvalue>b.ivalue];
real => RETURN[a.rvalue>b.rvalue];
ENDCASE;
string => WITH b:b SELECT FROM
string => RETURN[StringCompare[a,b]>0];
ENDCASE;
ENDCASE;
ERROR Error[typechk];
};

-- Intrinsics

JAdd: PUBLIC PROC[frame: Frame] = {
b: Object ← Pop[frame.opstk];
a: Object ← Pop[frame.opstk];
Push[frame.opstk,Add[a,b]];
};

JSub: PUBLIC PROC[frame: Frame] = {
b: Object ← Pop[frame.opstk];
a: Object ← Pop[frame.opstk];
Push[frame.opstk,Sub[a,b]];
};

JMul: PUBLIC PROC[frame: Frame] = {
b: Object ← Pop[frame.opstk];
a: Object ← Pop[frame.opstk];
Push[frame.opstk,Mul[a,b]];
};

JDiv: PUBLIC PROC[frame: Frame] = {
b: Object ← Pop[frame.opstk];
a: Object ← Pop[frame.opstk];
Push[frame.opstk,Div[a,b]];
};

JIDiv: PUBLIC PROC[frame: Frame] = {
b: Object ← Pop[frame.opstk];
a: Object ← Pop[frame.opstk];
Push[frame.opstk,IDiv[a,b]];
};

JRDiv: PUBLIC PROC[frame: Frame] = {
b: Object ← Pop[frame.opstk];
a: Object ← Pop[frame.opstk];
Push[frame.opstk,RDiv[a,b]];
};

JNeg: PUBLIC PROC[frame: Frame] = {
a: Object ← Pop[frame.opstk];
Push[frame.opstk,Neg[a]];
};

JSin: PUBLIC PROC[frame: Frame] = {
a: REAL ← PopReal[frame.opstk];
PushReal[frame.opstk,RealFns.SinDeg[a]];
};

JCos: PUBLIC PROC[frame: Frame] = {
a: REAL ← PopReal[frame.opstk];
PushReal[frame.opstk,RealFns.CosDeg[a]];
};

JATan: PUBLIC PROC[frame: Frame] = {
b: REAL ← PopReal[frame.opstk];
a: REAL ← PopReal[frame.opstk];
PushReal[frame.opstk,RealFns.ArcTanDeg[a,b]];
};

JExp: PUBLIC PROC[frame: Frame] = {
ENABLE Real.RealException => CHECKED {GOTO Overflow};
b: REAL ← PopReal[frame.opstk];
a: REAL ← PopReal[frame.opstk];
PushReal[frame.opstk,RealFns.Power[a,b]];
EXITS Overflow => ERROR Error[overflow];
};

JLog: PUBLIC PROC[frame: Frame] = {
b: REAL ← PopReal[frame.opstk];
a: REAL ← PopReal[frame.opstk];
IF a>0 AND b>0 THEN PushReal[frame.opstk,RealFns.Log[a,b]]
ELSE ERROR Error[rangechk];
};

JSqRt: PUBLIC PROC[frame: Frame] = {
a: REAL ← PopReal[frame.opstk];
IF a>=0 THEN PushReal[frame.opstk,RealFns.SqRt[a]]
ELSE ERROR Error[rangechk];
};

JEq: PUBLIC PROC[frame: Frame] = {
b: Object ← Pop[frame.opstk];
a: Object ← Pop[frame.opstk];
PushBoolean[frame.opstk,Eq[a,b]];
};

JLt: PUBLIC PROC[frame: Frame] = {
b: Object ← Pop[frame.opstk];
a: Object ← Pop[frame.opstk];
PushBoolean[frame.opstk,Lt[a,b]];
};

JGt: PUBLIC PROC[frame: Frame] = {
b: Object ← Pop[frame.opstk];
a: Object ← Pop[frame.opstk];
PushBoolean[frame.opstk,Gt[a,b]];
};

JNot: PUBLIC PROC[frame: Frame] = {
a: BOOLEAN ← PopBoolean[frame.opstk];
PushBoolean[frame.opstk,NOT a];
};

JAnd: PUBLIC PROC[frame: Frame] = {
b: BOOLEAN ← PopBoolean[frame.opstk];
a: BOOLEAN ← PopBoolean[frame.opstk];
PushBoolean[frame.opstk,a AND b];
};

JOr: PUBLIC PROC[frame: Frame] = {
b: BOOLEAN ← PopBoolean[frame.opstk];
a: BOOLEAN ← PopBoolean[frame.opstk];
PushBoolean[frame.opstk,a OR b];
};

JXor: PUBLIC PROC[frame: Frame] = {
b: BOOLEAN ← PopBoolean[frame.opstk];
a: BOOLEAN ← PopBoolean[frame.opstk];
PushBoolean[frame.opstk,a # b];
};

JBitNot: PUBLIC PROC[frame: Frame] = {
a,r: Inline.LongNumber;
a.li ← PopInteger[frame.opstk];
r.low ← Inline.BITNOT[a.low];
r.high ← Inline.BITNOT[a.high];
PushInteger[frame.opstk,r.li];
};

JBitAnd: PUBLIC PROC[frame: Frame] = {
a,b,r: Inline.LongNumber;
b.li ← PopInteger[frame.opstk];
a.li ← PopInteger[frame.opstk];
r.low ← Inline.BITAND[a.low,b.low];
r.high ← Inline.BITAND[a.high,b.high];
PushInteger[frame.opstk,r.li];
};

JBitOr: PUBLIC PROC[frame: Frame] = {
a,b,r: Inline.LongNumber;
b.li ← PopInteger[frame.opstk];
a.li ← PopInteger[frame.opstk];
r.low ← Inline.BITOR[a.low,b.low];
r.high ← Inline.BITOR[a.high,b.high];
PushInteger[frame.opstk,r.li];
};

JBitXor: PUBLIC PROC[frame: Frame] = {
a,b,r: Inline.LongNumber;
b.li ← PopInteger[frame.opstk];
a.li ← PopInteger[frame.opstk];
r.low ← Inline.BITXOR[a.low,b.low];
r.high ← Inline.BITXOR[a.high,b.high];
PushInteger[frame.opstk,r.li];
};

JBitShift: PUBLIC PROC[frame: Frame] = { OPEN Inline;
a,b,r: LongNumber;
shift: INTEGER;
b.li ← PopInteger[frame.opstk];
a.li ← PopInteger[frame.opstk];
r.li ← 0; IF b.li IN[-31..32] THEN SELECT (shift ← b.low) FROM
<-15 => { r.low ← BITSHIFT[a.high,shift+16] };
< 0 => { r.high ← BITSHIFT[a.high,shift];
r.low ← BITOR[BITSHIFT[a.low,shift],BITSHIFT[a.high,shift+16]] };
< 16 => { r.low ← BITSHIFT[a.low,shift];
r.high ← BITOR[BITSHIFT[a.high,shift],BITSHIFT[a.low,shift-16]] };
ENDCASE => { r.high ← BITSHIFT[a.low,shift-16] };
PushInteger[frame.opstk,r.li];
};


-- Initialization

InstallMath: PROC[why: InstallReason, frame: Frame] = { SELECT why FROM
register => {
-- Error name
overflow ← MakeName[".overflow"];
-- Math commands
RegisterExplicit[frame,".add"L,JAdd];
RegisterExplicit[frame,".sub"L,JSub];
RegisterExplicit[frame,".mul"L,JMul];
RegisterExplicit[frame,".div"L,JDiv];
RegisterExplicit[frame,".idiv"L,JIDiv];
RegisterExplicit[frame,".rdiv"L,JRDiv];
RegisterExplicit[frame,".neg"L,JNeg];
RegisterExplicit[frame,".sin"L,JSin];
RegisterExplicit[frame,".cos"L,JCos];
RegisterExplicit[frame,".atan"L,JATan];
RegisterExplicit[frame,".exp"L,JExp];
RegisterExplicit[frame,".log"L,JLog];
RegisterExplicit[frame,".sqrt"L,JSqRt];
RegisterExplicit[frame,".eq"L,JEq];
RegisterExplicit[frame,".lt"L,JLt];
RegisterExplicit[frame,".gt"L,JGt];
RegisterExplicit[frame,".not"L,JNot];
RegisterExplicit[frame,".and"L,JAnd];
RegisterExplicit[frame,".or"L,JOr];
RegisterExplicit[frame,".xor"L,JXor];
RegisterExplicit[frame,".bitnot"L,JBitNot];
RegisterExplicit[frame,".bitand"L,JBitAnd];
RegisterExplicit[frame,".bitor"L,JBitOr];
RegisterExplicit[frame,".bitxor"L,JBitXor];
RegisterExplicit[frame,".bitshift"L,JBitShift];
};
ENDCASE;
};

Install[InstallMath];

}.

Wyatt  7-Nov-81 14:14:30 change .div to do integer division for integer operands
    add .rdiv