-- 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

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 => 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 => 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 => 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 => 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 => 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 => 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 => 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