-- file Pass4Ops.mesa
-- last written by Satterthwaite, May 31, 1982 11:34 am

DIRECTORY
  Alloc: TYPE USING [Notifier],
  Literals: TYPE USING [Base, LitDescriptor, ltType],
  LiteralOps: TYPE USING [DescriptorValue, Find, FindDescriptor, Value],
  Log: TYPE USING [ErrorTree, WarningTree],
  P4: TYPE USING [
    RelOp, Repr, none, unsigned, both, other,
    CommonRep, TreeLiteral, StructuredLiteral],
  Pass4: TYPE USING [tFALSE, tTRUE],
  Real: FROM "IeeeFloat" USING [Abs, RealException, Negate, PairToReal],
  Symbols: TYPE USING [CSEIndex],
  Tree: TYPE USING [Base, Index, Link, Map, NodeName, Null, Scan, treeType],
  TreeOps: TYPE USING [
    FreeNode, GetNode, PopTree, PushLit, PushNode,
    ScanList, SetInfo, UpdateList];

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

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

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

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


 -- literals

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

  MakeTreeLiteral: PUBLIC PROC [val: WORD] RETURNS [Tree.Link] = {
    RETURN [[literal[info: [word[index: LiteralOps.Find[val]]]]]]};


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


  LongLiteralValue: PROC [t: Tree.Link] RETURNS [LONG UNSPECIFIED] = {
    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]]};

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


  LiteralRep: PUBLIC PROC [t: Tree.Link, rep: Repr] RETURNS [Repr] = {
    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]};


  IntToReal: PUBLIC PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
    v: LONG INTEGER = LongLiteralValue[tb[node].son[1]];
    overflow: BOOLEAN _ FALSE;
    r: REAL = Real.PairToReal[v, 0
		! Real.RealException => {overflow _ TRUE; RESUME}];
    IF overflow THEN {val _ [subtree[node]]; Log.ErrorTree[overflow, val]}
    ELSE {val _ MakeLongLiteral[r, tb[node].info]; FreeNode[node]};
    RETURN};

  SignWord: WORD = LAST[CARDINAL];
  
  ShortToLong: PUBLIC PROC [node: Tree.Index, rep: Repr] RETURNS [val: Tree.Link] = {
    w: ARRAY [0..1] OF WORD;
    w[0] _ TreeLiteralValue[tb[node].son[1]];
    w[1] _ IF P4.CommonRep[rep, P4.unsigned] # P4.none OR w[0] <= MaxSS THEN 0 ELSE SignWord;
    PushLit[LiteralOps.FindDescriptor[DESCRIPTOR[w]]];
    PushNode[mwconst, 1];  SetInfo[tb[node].info];  FreeNode[node];
    RETURN [PopTree[]]};
    
  LongToShort: PUBLIC PROC [node: Tree.Index, rep: Repr] RETURNS [val: Tree.Link] = {
    v, w: WORD;
    desc: Literals.LitDescriptor = TreeLiteralDesc[tb[node].son[1]];
    IF desc.length # 2 THEN ERROR;
    v _ ltb[desc.offset][0];  w _ ltb[desc.offset][1];
    IF P4.CommonRep[rep, P4.unsigned] # P4.none THEN {
      IF w # 0 THEN GO TO Overflow}
    ELSE
      IF (v <= MaxSS AND w # 0)
       OR (v > MaxSS AND w # SignWord) THEN GO TO Overflow;
    val _ MakeTreeLiteral[v];  FreeNode[node];
    EXITS
      Overflow => {
        val _ [subtree[node]]; Log.ErrorTree[boundsFault, tb[node].son[1]]}};


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


 -- 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 PROC [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOLEAN] = [
    TestSS, TestSU, TestLS, TestLU, TestOther];

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

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

  FoldExpr: PUBLIC PROC [node: Tree.Index, rep: Repr] RETURNS [val: Tree.Link] = {
    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 => {
	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]};
      in, notin => {
	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]};
      min, max => {
	VoidItem: Tree.Map = {RETURN[IF t=val THEN Tree.Null ELSE t]};
	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]};
      ENDCASE => ERROR};

  RelTest: PUBLIC PROC [l, r: Tree.Link, op: RelOp, rep: Repr] RETURNS [BOOLEAN] = {
    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]};

  IntervalTest: PUBLIC PROC [l, r: Tree.Link, rep: Repr] RETURNS [BOOLEAN] = {
    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] ]};


  Choose: PROC [list: Tree.Link, test: RelOp, rep: Repr] RETURNS [val: Tree.Link] = {
    started: BOOLEAN _ FALSE;

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

    ScanList[list, Item];  RETURN};


 -- operations

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

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

  UnarySS: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {
    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 => {
	tb[node].attr3 _ TRUE; t _ [subtree[node]]; Log.ErrorTree[overflow, t]}};

  BinarySS: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {
    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 => {
	tb[node].attr3 _ TRUE; t _ [subtree[node]]; Log.ErrorTree[overflow, t]}};


  MaxSU: CARDINAL = LAST[CARDINAL];

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

  UnarySU: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {
    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 => {
	tb[node].attr3 _ FALSE; t _ [subtree[node]]; Log.ErrorTree[overflow, t]}};

  BinarySU: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {
    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 => {
	tb[node].attr3 _ FALSE; t _ [subtree[node]]; Log.ErrorTree[overflow, t]}};


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

  TestLS: PROC [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOLEAN] = {
    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]};

  UnaryLS: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {
    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 => {
	tb[node].attr3 _ TRUE; t _ [subtree[node]]; Log.ErrorTree[overflow, t]}};

  BinaryLS: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {
    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 => {
	tb[node].attr3 _ TRUE; t _ [subtree[node]]; Log.ErrorTree[overflow, t]}};


  MaxLU: LONG CARDINAL = LAST[LONG CARDINAL];

  TestLU: PROC [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOLEAN] = {
    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]};

  UnaryLU: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {
    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 => {
	tb[node].attr3 _ FALSE; t _ [subtree[node]]; Log.ErrorTree[overflow, t]}};

  BinaryLU: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {
    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 => {
	tb[node].attr3 _ FALSE; t _ [subtree[node]]; Log.ErrorTree[overflow, t]}};


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

  UnaryOther: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {
    fail: BOOLEAN _ FALSE;
    IF tb[node].attr1	-- REAL
      THEN {
	ENABLE Real.RealException => {fail _ TRUE; RESUME};
	v: REAL;
	v1: REAL = LongLiteralValue[tb[node].son[1]];
	SELECT tb[node].name FROM
	  uminus => v _ Real.Negate[v1];
	  abs => v _ Real.Abs[v1];
	  ENDCASE => ERROR;
	IF fail THEN GO TO Overflow;
	t _ MakeLongLiteral[v, tb[node].info];  FreeNode[node];
	EXITS
	  Overflow => {
	    tb[node].attr3 _ TRUE; t _ [subtree[node]]; Log.WarningTree[overflow, t]}}
      ELSE ERROR};

  OpError: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {ERROR};

  END.