-- DIMath.mesa  Edited by Bruce,  Oct 16, 1980 11:47 PM

DIRECTORY
  ComData USING [typeCARDINAL, typeINT],
  DebugOps USING [Foo, InvalidNumber, Lengthen],
  DI USING [
    AbortWithError, Foo, Format, GetNumber, GetValue, LongNumFormat, MakeLongType,
    NumAddr, Number, NumberType, NumFormat, SEIndex, TypeForSe],
  DIActions USING [
    CheckLength, NumberLength, Pop, Push,
    PushLongVal, PushVal, Son, Tos],
  DOutput USING [Char, LongNumber, Number, Text],
  Dump USING [Char],
  DHeap USING [FreeLong],
  MachineDefs USING [BYTE],
  Storage USING [Node],
  Symbols USING [CSEIndex, CSENull, SEIndex, seType, typeANY],
  Table USING [Base, Bounds],
  Tree USING [Link, NodeName];
  
DIMath: PROGRAM 
  IMPORTS com: ComData, DebugOps, DI, DIActions, Dump, DOutput, DHeap, Storage, Table
  EXPORTS DIActions =
  BEGIN OPEN DI, DIActions;
  
  LengtheningGarbage: ERROR = CODE;
  
  CompType: TYPE = {min, max};
  
  PutReps: PUBLIC PROCEDURE [n: UNSPECIFIED] =
    BEGIN OPEN DOutput, LOOPHOLE[n,NumFormat];
    Cardinal[c]; Equals[]; Hex[c]; Equals[];
    Integer[i];
    IF b1 # 0 THEN
      BEGIN
      Equals[];
      Bytes[b1,b2];
      IF b1 > 15 OR b2 > 15 THEN
	BEGIN
	Equals[];
	Number[b1, [base: 8, zerofill: FALSE, unsigned: TRUE, columns: 0]];
	IF b1 > 7 THEN Char['B];
	Text[",,"L];
	Number[b2, [base: 8, zerofill: FALSE, unsigned: TRUE, columns: 0]];
	IF b2 > 7 THEN Char['B];
	END;
      IF b1 < 128 AND b2 < 128 THEN
	BEGIN
	Equals[];
	Dump.Char[b1]; Text[",,"L]; Dump.Char[b2];
	END;
      END
    ELSE IF b2 IN [1..127] THEN 
      BEGIN Equals[]; Dump.Char[b2]; END;
    IF n1 # 0 OR n3 # 0 THEN
      BEGIN
      Equals[];
      IF b1 # 0 THEN
	BEGIN
	IF n1 # 0 THEN
	  BEGIN
	  Number[n1, [base: 10, zerofill: FALSE, unsigned: TRUE, columns: 0]];
	  Char[':];
	  END;
	Number[n2, [base: 10, zerofill: FALSE, unsigned: TRUE, columns: 0]];
	Text[",,"L];
	END;
      IF n3 # 0 THEN
	BEGIN
	Number[n3, [base: 10, zerofill: FALSE, unsigned: TRUE, columns: 0]];
	Char[':];
	END;
      Number[n4, [base: 10, zerofill: FALSE, unsigned: TRUE, columns: 0]];
      END;
    END;
    
  Equals: PROCEDURE = BEGIN DOutput.Text[" = "L]; END;
  
  Cardinal: PROCEDURE [c: CARDINAL] = INLINE
    BEGIN OPEN DOutput;
    Number[c, [base: 8, zerofill: FALSE, unsigned: TRUE, columns: 0]];
    IF c > 7 THEN Char['B];
    END;
    
  Hex: PROCEDURE [c: CARDINAL] = INLINE
    BEGIN OPEN DOutput;
    Number[c, [base: 16, zerofill: FALSE, unsigned: TRUE, columns: 0]];
    IF c > 7 THEN Char['X];
    END;
    
  Integer: PROCEDURE [i: INTEGER] =
    BEGIN OPEN DOutput;
    Number[i, [base: 10, zerofill: FALSE, unsigned: TRUE, columns: 0]];
    IF i < 0 THEN
      BEGIN
      Equals[];
      Number[i, [base: 10, zerofill: FALSE, unsigned: FALSE, columns: 0]];
      END;
    END;
    
  Bytes: PROCEDURE [b1, b2: MachineDefs.BYTE] =
    BEGIN OPEN DOutput;
    Number[b1, [base: 10, zerofill: FALSE, unsigned: TRUE, columns: 0]];
    Text[",,"L];
    Number[b2, [base: 10, zerofill: FALSE, unsigned: TRUE, columns: 0]];
    END;
    
  PutLongReps: PUBLIC PROCEDURE [n: LONG UNSPECIFIED] =
    BEGIN OPEN DOutput, LOOPHOLE[n,LongNumFormat];
    LongNumber[c, [base: 8, zerofill: FALSE, unsigned: TRUE, columns: 0]];
    IF c > 7 THEN Char['B];
    Equals[];
    LongNumber[c, [base: 16, zerofill: FALSE, unsigned: TRUE, columns: 0]];
    IF c > 7 THEN Char['X];
    Equals[];
    LongNumber[c, [base: 10, zerofill: FALSE, unsigned: TRUE, columns: 0]];
    IF i < 0 THEN
      BEGIN
      Equals[];
      LongNumber[c, [base: 10, zerofill: FALSE, unsigned: FALSE, columns: 0]];
      END;
    Equals[]; Cardinal[w1]; Char[' ]; Cardinal[w2]; Equals[];
    Bytes[b1,b2]; Char[' ]; Bytes[b3,b4];
    END;
    
  LengthenFob: PUBLIC PROCEDURE [f: Foo] =
    BEGIN
    GetValue[f];
    IF ~CheckLength[f,1] THEN AbortWithError[cantLengthen];
    WITH Format[f.tsei].vf SELECT FROM
      int => Long[f, TRUE];
      card => Long[f, FALSE];
      string, pointer =>
	BEGIN
	new: POINTER TO LONG UNSPECIFIED _ Storage.Node[SIZE[LONG POINTER]];
	new^ _ DebugOps.Lengthen[f.addr.base^];
	DHeap.FreeLong[f.addr.base];
	f.addr.base _ new;
	f.words _ 2;
	END;
      ENDCASE;
    f.tsei _ MakeLongType[TypeForSe[f.tsei]];
    END;
    
  Abs: PUBLIC PROCEDURE [t: Tree.Link, target: Symbols.SEIndex] =
    BEGIN
    f: Foo _ Son[t,target];
    p: NumAddr;
    GetValue[f];
    p _ LOOPHOLE[f.addr.base];
    f.tsei _ com.typeINT;
    SELECT NumberLength[f] FROM
      nogood => AbortWithError[invalidNumber];
      one => p.pi^ _ ABS[p.pi^];
      two => p.pli^ _ ABS[p.pli^]
      ENDCASE;
    END;
    
  Long: PUBLIC PROCEDURE [f: Foo, signed: BOOLEAN] =
    BEGIN
    new: NumAddr _ LOOPHOLE[LONG[Storage.Node[SIZE[LONG UNSPECIFIED]]]];
    old: NumFormat _ LOOPHOLE[f.addr.base^];
    IF f.there THEN ERROR LengtheningGarbage;
    IF signed THEN new.pli^ _ LONG[old.i] ELSE new.plc^ _ LONG[old.c];
    DHeap.FreeLong[f.addr.base];
    f.addr.base _ LOOPHOLE[new];
    f.words _ 2;
    END;
    
  Compare: PROC [f1, f2: Foo, size: NumberType, compare: CompType, signed: BOOLEAN]
      RETURNS [Foo] =
    BEGIN
    addr1: NumAddr _ LOOPHOLE[f1.addr.base];
    addr2: NumAddr _ LOOPHOLE[f2.addr.base];
    firstSmallest: BOOLEAN;
    SELECT NIL FROM
      f1 => RETURN[f2];
      f2 => RETURN[f1];
      ENDCASE;
    IF signed THEN
      SELECT size FROM
	one => firstSmallest _ addr1.pi^ < addr2.pi^;
	two => firstSmallest _ addr1.pli^ < addr2.pli^;
	ENDCASE => ERROR DebugOps.InvalidNumber[f1]
    ELSE
      SELECT size FROM
	one => firstSmallest _ addr1.pc^ < addr2.pc^;
	two => firstSmallest _ addr1.plc^ < addr2.plc^;
	ENDCASE => ERROR DebugOps.InvalidNumber[f1];
    SELECT compare FROM
      min => IF firstSmallest THEN RETURN[f1] ELSE RETURN[f2];
      max => IF firstSmallest THEN RETURN[f2] ELSE RETURN[f1];
      ENDCASE => ERROR;
    END;
    
  MinMax: PROC [
      size: NumberType, cnt: CARDINAL, signed: BOOLEAN, comp: CompType] =
    BEGIN
    i: CARDINAL;
    f, current: Foo _ NIL;
    FOR i IN [0..cnt) DO
      f _ Pop[];
      IF ~CheckLength[f,LOOPHOLE[size]] THEN Long[f, signed];
      current _ Compare[f,current,size,comp,signed];
      ENDLOOP;
    Push[current];
    END;
    
  Max: PUBLIC PROCEDURE [size: NumberType, cnt: CARDINAL, signed: BOOLEAN] =
    BEGIN MinMax[size,cnt,signed,max]; END;
    
  Min: PUBLIC PROCEDURE [size: NumberType, cnt: CARDINAL, signed: BOOLEAN] =
    BEGIN MinMax[size,cnt,signed,min]; END;
    
  Inc: PUBLIC PROC [f: Foo, size: NumberType, signed: BOOLEAN] =
    BEGIN
    num: NumAddr _ LOOPHOLE[f.addr.base];
    IF signed THEN
      SELECT size FROM
	one => num.pi^ _ num.pi^ + 1;
	two => num.pli^ _ num.pli^ + 1;
	ENDCASE => ERROR DebugOps.InvalidNumber[f]
    ELSE
      SELECT size FROM
	one => num.pc^ _ num.pc^ + 1;
	two => num.plc^ _ num.plc^ + 1;
	ENDCASE => ERROR DebugOps.InvalidNumber[f];
    END;
    
  Dec: PUBLIC PROC [f: Foo, size: NumberType, signed: BOOLEAN] =
    BEGIN
    num: NumAddr _ LOOPHOLE[f.addr.base];
    IF signed THEN
      SELECT size FROM
	one => num.pi^ _ num.pi^ - 1;
	two => num.pli^ _ num.pli^ - 1;
	ENDCASE => ERROR DebugOps.InvalidNumber[f]
    ELSE
      SELECT size FROM
	one => num.pc^ _ num.pc^ - 1;
	two => num.plc^ _ num.plc^ - 1;
	ENDCASE => ERROR DebugOps.InvalidNumber[f];
    END;
    
  MakeCnt: PUBLIC PROC [top, sub: Foo, size: NumberType, signed: BOOLEAN] =
    BEGIN
    res: NumAddr _ LOOPHOLE[top.addr.base];
    num: NumAddr _ LOOPHOLE[sub.addr.base];
    IF signed THEN
      SELECT size FROM
	one => res.pi^ _ res.pi^ - num.pi^ + 1;
	two => res.pli^ _ res.pli^ - num.pli^ + 1;
	ENDCASE => ERROR DebugOps.InvalidNumber[top]
    ELSE
      SELECT size FROM
	one => res.pc^ _ res.pc^ - num.pc^ + 1;
	two => res.plc^ _ res.plc^ - num.plc^ + 1;
	ENDCASE => ERROR DebugOps.InvalidNumber[top];
    END;
    
  Repr: TYPE = [none..all];
    signed: CARDINAL = 1;
    unsigned: CARDINAL = 2;
    long: CARDINAL = 4;
    other: CARDINAL = 8;
    
    none: CARDINAL = 0;
    both: CARDINAL = signed+unsigned;
    all: CARDINAL = other+long+both;
    
-- literals

  TreeLiteralValue: PROC [f: Foo] RETURNS [WORD] =
    BEGIN
    n: Number = GetNumber[f];
    SELECT n.type FROM
      one => RETURN[n.u];
      ENDCASE => AbortWithError[sizeMismatch];
    ERROR;
    END;
    
  LongLiteralValue: PROC [f: Foo] RETURNS [LONG UNSPECIFIED] =
    BEGIN
    n: Number = GetNumber[f];
    SELECT n.type FROM
      one => {LengthenFob[f]; RETURN[LongLiteralValue[f]]};
      two => RETURN[n.lu];
      ENDCASE => AbortWithError[sizeMismatch];
    ERROR;
    END;
    
  MakeTreeLiteral: PROC [u: UNSPECIFIED, signed: BOOLEAN] =
    BEGIN
    PushVal[u, IF signed THEN com.typeINT ELSE com.typeCARDINAL];
    END;
    
  MakeLongLiteral: PROC [lu: LONG UNSPECIFIED, signed: BOOLEAN] =
    BEGIN
    PushLongVal[lu, IF signed THEN com.typeINT ELSE com.typeCARDINAL];
    END;
    
  AddRep: PROCEDURE [f: Foo, op: Tree.NodeName, csei: Symbols.CSEIndex, rep: Repr]
      RETURNS [Symbols.CSEIndex, Repr] =
    BEGIN
    new: Repr _ GetRep[f,op].rep;
    islong: BOOLEAN _ new > long OR rep > long;
    IF new > long AND rep < long THEN csei _ MakeLongType[csei];
    new _ new MOD long; rep _ rep MOD long;
    SELECT TRUE FROM
      rep = both => rep _ new;
      rep = signed => NULL;
      new = signed => rep _ signed;
      ENDCASE => rep _ unsigned;
    IF islong THEN rep _ rep + long;
    RETURN[csei,rep];
    END;
    
  GetRep: PROC [f: Foo, op: Tree.NodeName] RETURNS [csei: Symbols.CSEIndex, rep: Repr] =
    BEGIN
    subtraction: BOOLEAN _ op = minus OR op = uminus;
    n: Number _ GetNumber[f];
    signedNum: BOOLEAN _ IF n.type = one THEN n.sign ELSE n.lsign;
    [csei,rep] _ TypedRep[f];
    IF subtraction THEN
      csei _ IF n.type = one THEN com.typeINT ELSE MakeLongType[com.typeINT];
    SELECT rep MOD long FROM
      none => NULL;
      unsigned => IF subtraction THEN rep _ rep - 1;
      signed => IF ~subtraction AND ~signedNum THEN rep _ rep + 2;  -- make it both 
      both =>
	IF subtraction THEN rep _ rep - 2
	ELSE IF signedNum THEN rep _ rep - 1;  -- make it unsigned
      ENDCASE;
    IF n.type = two AND rep < long THEN rep _ rep + long;
    END;
    
  TypedRep: PROC [f: Foo] RETURNS [csei: Symbols.CSEIndex, rep: Repr] = 
    BEGIN
    seb: Table.Base _ Table.Bounds[Symbols.seType].base;
    save: Symbols.CSEIndex _ Symbols.CSENull;
    csei _ LOOPHOLE[f.tsei];
    rep _ none;
    DO
      SELECT csei FROM
	com.typeCARDINAL => rep _ rep + unsigned;
	com.typeINT => rep _ rep + signed;
	Symbols.typeANY => rep _ rep + both;
	ENDCASE => {
	  csei _ TypeForSe[csei];
	  WITH seb[csei] SELECT FROM
	    long => {rep _ long; save _ csei; csei _ TypeForSe[rangeType]; LOOP};
	    subrange => {save _ csei; csei _ TypeForSe[rangeType]; LOOP};
	    ref => rep _ rep + unsigned;
	    ENDCASE => rep _ rep + both};
      IF save # Symbols.CSENull THEN csei _ save;
      EXIT;
      ENDLOOP;
    END;
    
-- dispatch

  Mode: TYPE = {ss, su, ls, lu, other};
  
  ModeMap: ARRAY Repr OF Mode =
    [ss, ss, su, su, ls, ls, lu, lu,
    other, ss, su, su, other, ls, lu, lu];
    
  UnaryOp: ARRAY Mode OF PROC [node: Foo] =
    [UnarySS, UnarySU, UnaryLS, UnaryLU, UnaryOpError];
    
  BinaryOp: ARRAY Mode OF PROC [node: Foo, op: Tree.NodeName] =
    [BinarySS, BinarySU, BinaryLS, BinaryLU, OpError];
    
  FoldExpr: PUBLIC PROC [op: Tree.NodeName] =
    BEGIN
    left: Foo _ Pop[];
    tos: Foo;
    rep: Repr;
    csei: Symbols.CSEIndex;
    [csei, rep] _ GetRep[left, op];
    SELECT op FROM
      plus, minus, times, div, mod => {
	[csei, rep] _ AddRep[Tos[], op, csei, rep];
	BinaryOp[ModeMap[rep]][left,op]};
      uminus => UnaryOp[ModeMap[rep]][left];
      ENDCASE;
    tos _ Tos[];
    tos.tsei _ csei;
    END;
    
  -- operations
  
  MinSS: INTEGER = FIRST[INTEGER];
  MaxSS: INTEGER = LAST[INTEGER];
  
  UnarySS: PROC [node: Foo] =
    BEGIN
    v: INTEGER;
    v1: INTEGER = TreeLiteralValue[node];
    IF v1 # MinSS THEN v _ -v1 ELSE AbortWithError[overflow];
    MakeTreeLiteral[v,TRUE];
    END;
    
  BinarySS: PROC [node: Foo, op: Tree.NodeName] =
    BEGIN
    v: INTEGER;
    v1: INTEGER = TreeLiteralValue[node];
    v2: INTEGER = TreeLiteralValue[Pop[]];
    SELECT op FROM
      plus =>
	IF (IF v1 >= 0 THEN v2 <= MaxSS-v1 ELSE v2 >= MinSS-v1)
	  THEN  v _ v1 + v2
	  ELSE  GO TO Overflow;
      minus =>
	IF (IF v1 >= 0 THEN v1-MaxSS <= v2 ELSE v1-MinSS >= v2)
	  THEN  v _ v1 - v2
	  ELSE  GO TO Overflow;
      times =>
	IF (SELECT TRUE FROM
	    (v1 > 0) AND (v2 > 0) => v2 <= MaxSS / v1,
	    (v1 > 0) AND (v2 < 0) => v2 >= MinSS / v1,
	    (v1 < 0) AND (v2 > 0) => v1 >= MinSS / v2,
	    (v1 < 0) AND (v2 < 0) =>
		v1 # MinSS AND v2 # MinSS AND v2 >= MaxSS / v1,
	    ENDCASE => TRUE)
	  THEN  v _ v1 * v2
	  ELSE GO TO Overflow;
      div =>
	IF v2 # 0 AND (v2 # -1 OR v1 # MinSS)
	  THEN  v _ v1 / v2
	  ELSE  GO TO Overflow;
      mod =>
	IF v2 # 0 THEN v _ v1 MOD v2 ELSE GO TO Overflow;
      ENDCASE => ERROR;
    MakeTreeLiteral[v,TRUE];
    EXITS
      Overflow => AbortWithError[overflow];
    END;
    
    
  MaxSU: CARDINAL = LAST[CARDINAL];
  
  UnarySU: PROC [node: Foo] =
    BEGIN
    v1: CARDINAL = TreeLiteralValue[node];
    IF v1 # 0 THEN AbortWithError[overflow];
    MakeTreeLiteral[v1,FALSE];
    END;
    
  BinarySU: PROC [node: Foo, op: Tree.NodeName] =
    BEGIN
    v: CARDINAL;
    v1: CARDINAL = TreeLiteralValue[node];
    v2: CARDINAL = TreeLiteralValue[Pop[]];
    SELECT op FROM
      plus =>  IF v2 <= MaxSU-v1 THEN v _ v1 + v2 ELSE GO TO Overflow;
      minus => IF v1 >= v2 THEN v _ v1 - v2 ELSE GO TO Overflow;
      times =>
	IF v1 = 0 OR v2 <= MaxSU/v1 THEN v _ v1 * v2 ELSE GO TO Overflow;
      div =>   IF v2 # 0 THEN v _ v1 / v2 ELSE GO TO Overflow;
      mod =>   IF v2 # 0 THEN v _ v1 MOD v2 ELSE GO TO Overflow;
      ENDCASE => ERROR;
    MakeTreeLiteral[v,FALSE];
    EXITS
      Overflow => AbortWithError[overflow];
    END;
    
    
  MinLS: LONG INTEGER = FIRST[LONG INTEGER];
  MaxLS: LONG INTEGER = LAST[LONG INTEGER];
  
  UnaryLS: PROC [node: Foo] =
    BEGIN
    v: LONG INTEGER;
    v1: LONG INTEGER = LongLiteralValue[node];
    IF v1 # MinLS THEN v _ -v1 ELSE AbortWithError[overflow];
    MakeLongLiteral[v, TRUE];
    END;
    
  BinaryLS: PROC [node: Foo, op: Tree.NodeName]  =
    BEGIN
    v: LONG INTEGER;
    v1: LONG INTEGER = LongLiteralValue[node];
    v2: LONG INTEGER = LongLiteralValue[Pop[]];
    SELECT op FROM
      plus =>
	IF (IF v1 >= 0 THEN v2 <= MaxLS-v1 ELSE v2 >= MinLS-v1)
	  THEN  v _ v1 + v2
	  ELSE  GO TO Overflow;
      minus =>
	IF (IF v1 >= 0 THEN v1-MaxLS <= v2 ELSE v1-MinLS >= v2)
	  THEN  v _ v1 - v2
	  ELSE  GO TO Overflow;
      times =>
	IF (SELECT TRUE FROM
	    (v1 > 0) AND (v2 > 0) => v2 <= MaxLS / v1,
	    (v1 > 0) AND (v2 < 0) => v2 >= MinLS / v1,
	    (v1 < 0) AND (v2 > 0) => v1 >= MinLS / v2,
	    (v1 < 0) AND (v2 < 0) =>
		v1 # MinLS AND v2 # MinLS AND v2 >= MaxLS / v1,
	    ENDCASE => TRUE)
	  THEN  v _ v1 * v2
	  ELSE GO TO Overflow;
      div =>
	IF v2 # 0 AND (v2 # -1 OR v1 # MinLS)
	  THEN  v _ v1 / v2
	  ELSE  GO TO Overflow;
      mod =>
	IF v2 # 0 THEN v _ v1 MOD v2 ELSE GO TO Overflow;
      ENDCASE => ERROR;
    MakeLongLiteral[v, TRUE];
    EXITS
      Overflow => AbortWithError[overflow];
    END;
    
    
  MaxLU: LONG CARDINAL = LAST[LONG CARDINAL];
  
  UnaryLU: PROC [node: Foo] =
    BEGIN
    v1: LONG CARDINAL = LongLiteralValue[node];
    IF v1 # 0 THEN AbortWithError[overflow];
    MakeLongLiteral[v1,FALSE];
    END;
    
  BinaryLU: PROC [node: Foo, op: Tree.NodeName] =
    BEGIN
    v: LONG CARDINAL;
    v1: LONG CARDINAL = LongLiteralValue[node];
    v2: LONG CARDINAL = LongLiteralValue[Pop[]];
    SELECT op FROM
      plus =>  IF v2 <= MaxLU-v1 THEN v _ v1 + v2 ELSE GO TO Overflow;
      minus => IF v1 >= v2 THEN v _ v1 - v2 ELSE GO TO Overflow;
      times =>
	IF v1 = 0 OR v2 <= MaxLU/v1 THEN v _ v1 * v2 ELSE GO TO Overflow;
      div =>   IF v2 # 0 THEN v _ v1 / v2 ELSE GO TO Overflow;
      mod =>   IF v2 # 0 THEN v _ v1 MOD v2 ELSE GO TO Overflow;
      ENDCASE => ERROR;
    MakeLongLiteral[v,FALSE];
    EXITS
      Overflow => AbortWithError[overflow];
    END;
    
  OpError: PROC [node: Foo, op: Tree.NodeName] = {AbortWithError[overflow]};
  UnaryOpError: PROC [node: Foo] = {AbortWithError[overflow]};
  
  END.