-- file Pass4Ops.Mesa
-- last written by Satterthwaite, October 30, 1979  3:05 PM

DIRECTORY
  Literals: FROM "literals" USING [LitDescriptor, ltType],
  LiteralOps: FROM "literalops"
    USING [DescriptorValue, Find, FindDescriptor, Value],
  Log: FROM "log" USING [ErrorTree],
  P4: FROM "p4"
    USING [
      RelOp, Repr, none, unsigned, both, other,
      TreeLiteral, StructuredLiteral],
  Pass4: FROM "pass4" USING [tFALSE, tTRUE],
  Symbols: FROM "symbols" USING [CSEIndex],
  Table: FROM "table" USING [Base, Notifier],
  Tree: FROM "tree" USING [treeType, Index, Link, Map, NodeName, Null, Scan],
  TreeOps: FROM "treeops"
    USING [
      FreeNode, GetNode, PopTree, PushLit, PushNode,
      ScanList, SetInfo, UpdateList];

Pass4Ops: PROGRAM
    IMPORTS LiteralOps, Log, P4, TreeOps, passPtr: Pass4
    EXPORTS P4 =
  BEGIN
  OPEN TreeOps;

  RelOp: TYPE = P4.RelOp;
  Repr: TYPE = P4.Repr;

  tb: Table.Base;	-- tree base address (local copy)
  ltb: Table.Base;	-- literal table base address (local copy)

  OpsNotify: PUBLIC Table.Notifier =
    BEGIN  -- called by allocator whenever table area is repacked
    tb _ base[Tree.treeType];  ltb _ base[Literals.ltType];
    END;


 -- literals

  TreeLiteralValue: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [WORD] =
    BEGIN
    node: Tree.Index;
      DO
      WITH e:t SELECT FROM
	literal =>
	  WITH e.info SELECT FROM
	    word => RETURN [LiteralOps.Value[index]];
	    ENDCASE => EXIT;
	subtree =>
	  BEGIN  node _ e.index;
	  SELECT tb[node].name FROM
	    cast =>  t _ tb[node].son[1];
	    ENDCASE => EXIT;
	  END;
	ENDCASE => EXIT
      ENDLOOP;
    ERROR;
    END;

  MakeTreeLiteral: PUBLIC PROCEDURE [val: WORD] RETURNS [Tree.Link] =
    BEGIN
    RETURN [[literal[info: [word[index: LiteralOps.Find[val]]]]]]
    END;


  TreeLiteralDesc: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [Literals.LitDescriptor] =
    BEGIN
    WITH t SELECT FROM
      literal =>
	WITH info SELECT FROM
	  word => RETURN [LiteralOps.DescriptorValue[index]];
	  ENDCASE;
      subtree =>
	BEGIN
	node: Tree.Index = index;
	SELECT tb[node].name FROM
	  mwconst, cast => RETURN [TreeLiteralDesc[tb[node].son[1]]];
	  ENDCASE;
	END;
      ENDCASE;
    ERROR
    END;


  LongLiteralValue: PROCEDURE [t: Tree.Link] RETURNS [LONG UNSPECIFIED] =
    BEGIN
    w: ARRAY [0..1] OF WORD;
    desc: Literals.LitDescriptor = TreeLiteralDesc[t];
    IF desc.length # 2 THEN ERROR;
    w[0] _ ltb[desc.offset][0];  w[1] _ ltb[desc.offset][1];
    RETURN [LOOPHOLE[w]]
    END;

  MakeLongLiteral: PROCEDURE [val: LONG UNSPECIFIED, type: Symbols.CSEIndex]
      RETURNS [Tree.Link] =
    BEGIN
    w: ARRAY [0..1] OF WORD _ LOOPHOLE[val];
    PushLit[LiteralOps.FindDescriptor[DESCRIPTOR[w]]];
    PushNode[mwconst, 1];  SetInfo[type];
    RETURN [PopTree[]]
    END;


  LiteralRep: PUBLIC PROCEDURE [t: Tree.Link, rep: Repr] RETURNS [Repr] =
    BEGIN
    desc: Literals.LitDescriptor;
    RETURN [SELECT TRUE FROM
      rep = P4.other, rep = P4.none => rep,
      P4.TreeLiteral[t] => 
	IF TreeLiteralValue[t] > 77777B
	  THEN IF rep = P4.both THEN P4.unsigned ELSE rep
	  ELSE P4.both,
      P4.StructuredLiteral[t] =>
	IF (desc_TreeLiteralDesc[t]).length = 2
	  THEN
	    IF ltb[desc.offset][1] > 77777B
	      THEN IF rep = P4.both THEN P4.unsigned ELSE rep
	      ELSE P4.both
	  ELSE P4.other,
      ENDCASE => rep]
    END;


  ZeroP: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [zero: BOOLEAN] =
    BEGIN
    IF ~P4.StructuredLiteral[t]
      THEN  zero _ FALSE
      ELSE
	BEGIN
	desc: Literals.LitDescriptor = TreeLiteralDesc[t];
	i: CARDINAL;
	zero _ TRUE;
	FOR i IN [0..desc.length) WHILE (zero_(ltb[desc.offset][i] = 0))
	  DO NULL ENDLOOP;
	END;
    RETURN
    END;


 -- dispatch

  Mode: TYPE = {ss, su, ls, lu, other};

  ModeMap: ARRAY Repr OF Mode =
    [ss, ss, su, ss, ls, ls, lu, ls,
     other, ss, su, ss, other, ls, lu, ls];

  InOp: TYPE = Tree.NodeName [in .. notin];
  IntOp: TYPE = Tree.NodeName [intOO .. intCC];

  Test: ARRAY Mode OF
      PROCEDURE [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOLEAN] =
    [TestSS, TestSU, TestLS, TestLU, TestOther];

  UnaryOp: ARRAY Mode OF PROCEDURE [node: Tree.Index] RETURNS [Tree.Link] =
    [UnarySS, UnarySU, UnaryLS, UnaryLU, OpError];

  BinaryOp: ARRAY Mode OF PROCEDURE [node: Tree.Index] RETURNS [Tree.Link] =
    [BinarySS, BinarySU, BinaryLS, BinaryLU, OpError];

  FoldExpr: PUBLIC PROCEDURE [node: Tree.Index, rep: Repr] RETURNS [val: Tree.Link] =
    BEGIN
    SELECT tb[node].name FROM
      plus, minus, times, div, mod =>  val _ BinaryOp[ModeMap[rep]][node];
      abs, uminus =>  val _ UnaryOp[ModeMap[rep]][node];
      relE, relN, relL, relGE, relG, relLE =>
	BEGIN
	val _ IF RelTest [
		l: tb[node].son[1], r: tb[node].son[2],
		op: tb[node].name,
		rep: rep]
	  THEN passPtr.tTRUE
	  ELSE passPtr.tFALSE;
	FreeNode[node];
	END;
      in, notin =>
	BEGIN
	val _ IF
	     IntervalTest [l: tb[node].son[1], r: tb[node].son[2], rep: rep]
	      =
	     (tb[node].name = in)
	  THEN passPtr.tTRUE
	  ELSE passPtr.tFALSE;
	FreeNode[node];
	END;
      min, max =>
	BEGIN
	VoidItem: Tree.Map = BEGIN RETURN[IF t=val THEN Tree.Null ELSE t] END;
	val _ Choose[
		list: tb[node].son[1],
		test: IF tb[node].name = min THEN relL ELSE relG,
		rep: rep];
	tb[node].son[1] _ UpdateList[tb[node].son[1], VoidItem];
	FreeNode[node];
	END;
      ENDCASE => ERROR;
    END;

  RelTest: PUBLIC PROCEDURE [l, r: Tree.Link, op: RelOp, rep: Repr] RETURNS [BOOLEAN] =
    BEGIN
    OpMap: ARRAY RelOp OF RECORD [map: RelOp, sense: BOOLEAN] =
     [[relE, TRUE], [relE, FALSE], [relL, TRUE], [relL, FALSE],
      [relG, TRUE], [relG, FALSE]];
    RETURN [Test[ModeMap[rep]][l, r, OpMap[op].map] = OpMap[op].sense]
    END;

  IntervalTest: PUBLIC PROCEDURE [l, r: Tree.Link, rep: Repr] RETURNS [BOOLEAN] =
    BEGIN
    InTest: ARRAY IntOp OF RECORD [lb, ub: RelOp] =
     [[relG, relL], [relG, relLE], [relGE, relL], [relGE, relLE]];
    subNode: Tree.Index = GetNode[r];
    op: IntOp = tb[subNode].name;
    RETURN [
	RelTest[l, tb[subNode].son[1], InTest[op].lb, rep]
	  AND
	RelTest[l, tb[subNode].son[2], InTest[op].ub, rep] ]
    END;


  Choose: PROCEDURE [list: Tree.Link, test: RelOp, rep: Repr] RETURNS [val: Tree.Link] =
    BEGIN
    started: BOOLEAN;

    Item: Tree.Scan =
      BEGIN
      SELECT TRUE FROM
	~started =>  BEGIN  started _ TRUE;  val _ t  END;
	RelTest[t, val, test, rep] =>  val _ t;
	ENDCASE;
      END;

    started _ FALSE;  ScanList[list, Item];  RETURN
    END;


 -- operations

  MinSS: INTEGER = FIRST[INTEGER];
  MaxSS: INTEGER = LAST[INTEGER];

  TestSS: PROCEDURE [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOLEAN] =
    BEGIN
    v1: INTEGER = TreeLiteralValue[t1];
    v2: INTEGER = TreeLiteralValue[t2];
    RETURN [SELECT op FROM
      relE => v1 = v2,
      relL => v1 < v2,
      relG => v1 > v2,
      ENDCASE => ERROR]
    END;

  UnarySS: PROCEDURE [node: Tree.Index] RETURNS [t: Tree.Link] =
    BEGIN
    v: INTEGER;
    v1: INTEGER = TreeLiteralValue[tb[node].son[1]];
    SELECT tb[node].name FROM
      uminus =>  IF v1 # MinSS THEN v _ -v1 ELSE GO TO Overflow;
      abs =>
	IF v1 # MinSS THEN v _ IF v1 < 0 THEN -v1 ELSE v1 ELSE GO TO Overflow;
      ENDCASE => ERROR;
    t _ MakeTreeLiteral[v];  FreeNode[node];
    EXITS
      Overflow =>
	BEGIN
	tb[node].attr3 _ TRUE;  t _ [subtree[node]];
	Log.ErrorTree[overflow, t]
	END;
    END;

  BinarySS: PROCEDURE [node: Tree.Index] RETURNS [t: Tree.Link] =
    BEGIN
    v: INTEGER;
    v1: INTEGER = TreeLiteralValue[tb[node].son[1]];
    v2: INTEGER = TreeLiteralValue[tb[node].son[2]];
    SELECT tb[node].name 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;
    t _ MakeTreeLiteral[v];  FreeNode[node];
    EXITS
      Overflow =>
	BEGIN
	tb[node].attr3 _ TRUE;  t _ [subtree[node]];
	Log.ErrorTree[overflow, t]
	END;
    END;


  MaxSU: CARDINAL = LAST[CARDINAL];

  TestSU: PROCEDURE [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOLEAN] =
    BEGIN
    v1: CARDINAL = TreeLiteralValue[t1];
    v2: CARDINAL = TreeLiteralValue[t2];
    RETURN [SELECT op FROM
      relE => v1 = v2,
      relL => v1 < v2,
      relG => v1 > v2,
      ENDCASE => ERROR]
    END;

  UnarySU: PROCEDURE [node: Tree.Index] RETURNS [t: Tree.Link] =
    BEGIN
    v1: CARDINAL = TreeLiteralValue[tb[node].son[1]];
    SELECT tb[node].name FROM
      uminus =>  IF v1 # 0 THEN  GO TO Overflow;
      abs =>  NULL;
      ENDCASE => ERROR;
    t _ MakeTreeLiteral[v1];  FreeNode[node];
    EXITS
      Overflow =>
	BEGIN
	tb[node].attr3 _ FALSE;  t _ [subtree[node]];
	Log.ErrorTree[overflow, t];
	END;
    END;

  BinarySU: PROCEDURE [node: Tree.Index] RETURNS [t: Tree.Link] =
    BEGIN
    v: CARDINAL;
    v1: CARDINAL = TreeLiteralValue[tb[node].son[1]];
    v2: CARDINAL = TreeLiteralValue[tb[node].son[2]];
    SELECT tb[node].name 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;
    t _ MakeTreeLiteral[v];  FreeNode[node];
    EXITS
      Overflow =>
	BEGIN
	tb[node].attr3 _ FALSE;  t _ [subtree[node]];
	Log.ErrorTree[overflow, t];
	END;
    END;


  MinLS: LONG INTEGER = FIRST[LONG INTEGER];
  MaxLS: LONG INTEGER = LAST[LONG INTEGER];

  TestLS: PROCEDURE [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOLEAN] =
    BEGIN
    v1: LONG INTEGER = LongLiteralValue[t1];
    v2: LONG INTEGER = LongLiteralValue[t2];
    RETURN [SELECT op FROM
      relE => v1 = v2,
      relL => v1 < v2,
      relG => v1 > v2,
      ENDCASE => ERROR]
    END;

  UnaryLS: PROCEDURE [node: Tree.Index] RETURNS [t: Tree.Link] =
    BEGIN
    v: LONG INTEGER;
    v1: LONG INTEGER = LongLiteralValue[tb[node].son[1]];
    SELECT tb[node].name FROM
      uminus =>  IF v1 # MinLS THEN v _ -v1 ELSE GO TO Overflow;
      abs =>
	IF v1 # MinLS THEN v _ IF v1 < 0 THEN -v1 ELSE v1 ELSE GO TO Overflow;
      ENDCASE => ERROR;
    t _ MakeLongLiteral[v, tb[node].info];  FreeNode[node];
    EXITS
      Overflow =>
	BEGIN
	tb[node].attr3 _ TRUE;  t _ [subtree[node]];
	Log.ErrorTree[overflow, t]
	END;
    END;

  BinaryLS: PROCEDURE [node: Tree.Index] RETURNS [t: Tree.Link] =
    BEGIN
    v: LONG INTEGER;
    v1: LONG INTEGER = LongLiteralValue[tb[node].son[1]];
    v2: LONG INTEGER = LongLiteralValue[tb[node].son[2]];
    SELECT tb[node].name 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;
    t _ MakeLongLiteral[v, tb[node].info];  FreeNode[node];
    EXITS
      Overflow =>
	BEGIN
	tb[node].attr3 _ TRUE;  t _ [subtree[node]];
	Log.ErrorTree[overflow, t]
	END;
    END;


  MaxLU: LONG CARDINAL = LAST[LONG CARDINAL];

  TestLU: PROCEDURE [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOLEAN] =
    BEGIN
    v1: LONG CARDINAL = LongLiteralValue[t1];
    v2: LONG CARDINAL = LongLiteralValue[t2];
    RETURN [SELECT op FROM
      relE => v1 = v2,
      relL => v1 < v2,
      relG => v1 > v2,
      ENDCASE => ERROR]
    END;

  UnaryLU: PROCEDURE [node: Tree.Index] RETURNS [t: Tree.Link] =
    BEGIN
    v1: LONG CARDINAL = LongLiteralValue[tb[node].son[1]];
    SELECT tb[node].name FROM
      uminus =>  IF v1 # 0 THEN  GO TO Overflow;
      abs =>  NULL;
      ENDCASE => ERROR;
    t _ MakeLongLiteral[v1, tb[node].info];  FreeNode[node];
    EXITS
      Overflow =>
	BEGIN
	tb[node].attr3 _ FALSE;  t _ [subtree[node]];
	Log.ErrorTree[overflow, t];
	END;
    END;

  BinaryLU: PROCEDURE [node: Tree.Index] RETURNS [t: Tree.Link] =
    BEGIN
    v: LONG CARDINAL;
    v1: LONG CARDINAL = LongLiteralValue[tb[node].son[1]];
    v2: LONG CARDINAL = LongLiteralValue[tb[node].son[2]];
    SELECT tb[node].name 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;
    t _ MakeLongLiteral[v, tb[node].info];  FreeNode[node];
    EXITS
      Overflow =>
	BEGIN
	tb[node].attr3 _ FALSE;  t _ [subtree[node]];
	Log.ErrorTree[overflow, t];
	END;
    END;


  TestOther: PROCEDURE [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOLEAN] =
    BEGIN
    RETURN [SELECT op FROM
      relE => TreeLiteralDesc[t1] = TreeLiteralDesc[t2],
      ENDCASE => ERROR]
    END;

  OpError: PROCEDURE [node: Tree.Index] RETURNS [t: Tree.Link] =
    BEGIN
    ERROR
    END;

  END.