
<<MicroAccumulateImpl.mesa>>
    <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
    <<Willie-sue, February 27, 1986 2:21:10 pm PST>>

<<taken from MicAcc.bcpl>>

DIRECTORY
Basics,
IO,
Rope,

MicroDefs,
MicroGlobalVars,
MicroOps,
MicroUtils USING [];

MicroAccumulateImpl: CEDAR PROGRAM

IMPORTS
Basics, IO,
MicroDefs, MicroGlobalVars, MicroOps

EXPORTS
MicroOps, MicroUtils

= BEGIN OPEN MicroDefs, MicroGlobalVars;

MemStackObj: TYPE = REF MemStackRec;
MemStackRec: TYPE = RECORD[
prev: MemStackObj _ NIL,
accWord: WordSeq _ NIL,        -- word being assembled
used: WordSeq _ NIL,            -- bits already stored into
memory: Memory _ NIL,            -- current memory
listingBuf: WordSeq _ NIL,
anyStores: BOOL _ FALSE,            -- true if any stores done
location: INTEGER _ 0,            -- current location in memory
symIndex: INTEGER _ 0            -- of current field (?)
];

currentMem: MemStackObj _ NIL;

RestartAcc: PUBLIC PROC = {
UNTIL currentMem = NIL DO
symb: SymbolObj = MicroOps.GetSymbol[currentMem.symIndex];
symb.sVal _ 0;        -- reset memory location counter
currentMem _ currentMem.prev;
ENDLOOP;
targetSym _ 0;
};

InitAcc: PUBLIC PROC = {
<<Initialize accumulator>>
currentMem _ NIL;
ClearAssemWord[0];
IF targetSym # 0 THEN TargetSet[targetSym];
};

Assemble: PUBLIC PROC = {
<<Assemble top level word>>
IF currentMem # NIL THEN ClearAssemWord[currentMem.symIndex];
MicroOps.ProcessOneClause[accumulateVal];
IF currentMem.anyStores THEN {
IF (currentMem.memory.memSymPost # 0) THEN APost[currentMem.memory];
Produce[];
};
};

Produce: PROC = {
<<Produce assembled word>>
IF currentMem.location >= currentMem.memory.size THEN {
MicroOps.ReportError[IO.PutFR["\n *** Store out of range to %g in %g\n",
IO.int[currentMem.location],
IO.rope[MicroOps.GetSymbol[currentMem.memory.symIndex].name] ],
FALSE];
RETURN
};
MicroOps.WriteWord[currentMem.accWord, currentMem.memory, currentMem.location];
IF currentMem.listingBuf # NIL THEN {
options: WORD = currentMem.memory.listOptions;
IF Basics.BITAND[options, LFany] # 0 THEN
MicroOps.ListWord[
currentMem.accWord, currentMem.listingBuf, currentMem.memory, currentMem.location, options];
};
currentMem.symIndex _
MicroOps.AddressTagDefn[currentMem.symIndex, currentMem.memory, currentMem.location+1];
};

ClearAssemWord: PROC[symIndex: INTEGER] = {
<<Clear Assembled Word>>
IF currentMem # NIL THEN {
IF currentMem.listingBuf # NIL THEN MakeTempZero[currentMem.listingBuf];
IF currentMem.memory # NIL AND currentMem.memory.accumWord # NIL THEN {
FOR i: INTEGER IN [0.. currentMem.memory.accumWord.length) DO
currentMem.accWord[i] _ currentMem.memory.accumWord[i];
ENDLOOP;
currentMem.memory.lTag _ 0;
};
currentMem.anyStores _ FALSE;
MakeZero[currentMem.used];
}
ELSE currentMem _ NEW[MemStackRec _ []];

currentMem.symIndex _ symIndex;
currentMem.location _ MicroOps.GetSymbol[symIndex].sVal;
};

SetField: PUBLIC PROC[symIndex: INTEGER, val: WORD, set: BOOL] = {
<<Store val into field with name GetSymbol[symIndex].name>>
<<Error if something is in the field already, value is too big for field, or the field is too big for the memory (overflow the 
memory)>>
OPEN Basics;
symbol: SymbolObj = MicroOps.GetSymbol[symIndex];
firstBitNum: INT = symbol.sMisc;
numBits: INTEGER = LOOPHOLE[symbol.sVal, INTEGER];
IF currentMem = NIL THEN ERROR MicroDefs.Error["No target for field set"];

IF firstBitNum+numBits > currentMem.memory.widthInBits THEN {
MicroOps.ReportError[IO.PutFR["\n *** Field %g doesn't fit in memory %g\n",
IO.rope[symbol.name],
IO.rope[MicroOps.GetSymbol[currentMem.memory.symIndex].name] ],
FALSE];
RETURN
};
IF Basics.BITSHIFT[val, -numBits] # 0 THEN {
MicroOps.ReportError[IO.PutFR["\n *** Value %g doesn't fit in field %g\n",
IO.card[LOOPHOLE[val, CARDINAL]], IO.rope[symbol.name] ],
FALSE];
RETURN
};
BEGIN
used: WORD _ GetBits[currentMem.used, firstBitNum, numBits];
IF set THEN {
IF (used # 0) AND
(BITAND[GetBits[currentMem.accWord, firstBitNum, numBits], used] # BITAND[val, used]) THEN {
MicroOps.ReportError[IO.PutFR["\n *** Field %g already set\n", IO.rope[symbol.name] ],
FALSE];
RETURN
};
SetBits[currentMem.used, firstBitNum, numBits, 177777B];
SetBits[currentMem.accWord, firstBitNum, numBits, val];
}
ELSE
IF used # (BITSHIFT[1, numBits] - 1) THEN {
valToStore: WORD _ IF used = 0 THEN val ELSE
BITAND[GetBits[currentMem.accWord, firstBitNum, numBits], used] +
BITAND[val, BITNOT[used]];
SetBits[currentMem.accWord, firstBitNum, numBits, valToStore];
};
END;
currentMem.anyStores _ TRUE;
};

GetField: PUBLIC PROC[symIndex: INTEGER] RETURNS[WORD] = {
symbol: SymbolObj = MicroOps.GetSymbol[symIndex];
IF currentMem = NIL THEN ERROR
MicroDefs.Error[IO.PutFR["\nNo target for GetField of %g\n", IO.rope[symbol.name]] ];
RETURN[GetBits[currentMem.accWord, symbol.sMisc, LOOPHOLE[symbol.sVal, INTEGER]] ];
};

TargetSet: PUBLIC PROC[symIndex: INTEGER] = {
memIndex: INTEGER;
IF currentMem.prev # NIL THEN ERROR MicroDefs.Error["\"Target\" not legal inside Store\n"];
IF currentMem.anyStores THEN ERROR MicroDefs.Error["\"Target\" given after field set\n"];

MemPop[];
memIndex _ MicroOps.GetSymbol[symIndex].sMisc;
MemPush[NARROW[MicroOps.GetSymbol[memIndex].sData]];
ClearAssemWord[symIndex];
targetSym _ symIndex;
};

MemPush: PROC[newMem: Memory] = {
<<Push currentMem accumulator>>
length: NAT = newMem.widthInWords;

currentMem _ NEW[MemStackRec _ [
prev: currentMem,
memory: newMem,
accWord: NEW[WordSeqRec[length]],
used: NEW[WordSeqRec[length]]
] ];

MakeZero[currentMem.accWord];
MakeZero[currentMem.used];

IF expandedListingFlag AND ((currentMem.prev = NIL) OR (listTargetOnlyFlag = FALSE)) THEN {
currentMem.listingBuf _ NEW[WordSeqRec[newMem.widthInBits]];
MakeTempZero[currentMem.listingBuf];
}
ELSE currentMem.listingBuf _ NIL;
};

MemPop: PROC = {
<<Pop old accumulator>>
currentMem _ currentMem.prev;
};

LabelDefn: PUBLIC PROC[symIndex: INTEGER, symb: ATOM] = {
sObj: SymbolObj;
IF symIndex = 0 THEN [symIndex, sObj] _ MicroOps.PutInSymbol[symb, addressType]
ELSE sObj _ MicroOps.GetSymbol[symIndex];
sObj.sMisc _ currentMem.memory.symIndex;

symIndex _ MicroOps.AddressTagDefn[symIndex, currentMem.memory, currentMem.location];
IF currentMem.prev = NIL THEN
{ labelSymIndex _ symIndex; labelLineCount _ stmtLineCount };
};

UndefnRef: PUBLIC PROC[feIndex: INTEGER, symIndex: INTEGER] = {
<<Write undefined reference>>
sObj: SymbolObj = MicroOps.GetSymbol[symIndex];
IF currentMem.symIndex = 0 THEN
MicroOps.ReportError[
IO.PutFR["\n *** Undefined symbol %g in 'DEFAULT'\n", IO.rope[sObj.name]],
FALSE]
ELSE {
MicroOps.WriteFixup[currentMem.memory.symIndex, currentMem.location, feIndex, symIndex];
currentMem.anyStores _ TRUE;
};
};

IsFieldSet: PUBLIC PROC[symIndex: INTEGER] RETURNS[BOOL] = {
<<Test if field has been set>>
symb: SymbolObj = MicroOps.GetSymbol[symIndex];
RETURN[GetBits[currentMem.used, symb.sMisc, LOOPHOLE[symb.sVal, INTEGER]] # 0]
};

StoreBuiltin: PUBLIC PROC[
    symIndex: INTEGER, aPtr: LONG POINTER TO WORD, lx: INTEGER] = {
memIndex: INTEGER = MicroOps.GetSymbol[symIndex].sMisc;
mem: Memory = NARROW[MicroOps.GetSymbol[memIndex].sData];
MemPush[mem];
ClearAssemWord[symIndex];
[] _ MicroOps.ProcessStmt[aPtr, lx, accumulateVal];
IF (mem.memSymPost # 0) THEN APost[mem];
Produce[];
MemPop[];
};

DefaultBuiltin: PUBLIC PROC[
    symIndex: INTEGER, aPtr: LONG POINTER TO WORD, lx: INTEGER] = {
mem: Memory;
sObj: SymbolObj;

sObj _ MicroOps.GetSymbol[symIndex];
MemPush[mem _ NARROW[sObj.sData]];
ClearAssemWord[0];
[] _ MicroOps.ProcessStmt[aPtr, lx, accumulateVal];
mem.accumWord _ currentMem.accWord;        -- move bits to the memory
MemPop[];
};

SetListFieldsBuiltin: PUBLIC PROC[
    symIndex: INTEGER, aPtr: LONG POINTER TO WORD,  lx: INTEGER] = TRUSTED {
bn: INTEGER _ 0;
sObj: SymbolObj;
mem: Memory;
map: WordSeq;
memWidth: INTEGER;
i: NAT _ 0;

sObj _ MicroOps.GetSymbol[symIndex];
mem _ NARROW[sObj.sData];
map _ mem.listFields;
memWidth _ mem.widthInBits;

MemPush[mem];
ClearAssemWord[0];
[] _ MicroOps.ProcessStmt[aPtr, lx, accumulateVal];

WHILE (bn # memWidth) DO
bn1: INTEGER _ bn;
DO
bn _ bn + 1;
IF (bn = memWidth) OR (GetBits[currentMem.accWord, bn-1, 1] # 0) THEN EXIT;
ENDLOOP;
map[i] _ LOOPHOLE[bn - bn1];
i _ i + 1;
ENDLOOP;
MemPop[];
};

APost: PROC[mem: Memory] = {
<<Do the post-macro for memory mem>>
old: NAT _ stmtTailBottom;
[] _ MicroOps.PushStmtChar[endc];        -- set end mark
MicroOps.MacroCall[mem.memSymPost, 0];
MicroOps.ProcessOneClause[accumulateVal];
stmtTailBottom _ old;
};

GetBits: PUBLIC PROC[acw: WordSeq, firstBitNum, numBits: INTEGER]
        RETURNS[WORD] = {
<< this code depends on no field being more than 16 bits wide>>
OPEN Basics;
mask: WORD = MakeMask[numBits];
whichCase: WhichBitsCase;
shift, index: NAT;

[whichCase, index, shift] _ WhichBits[firstBitNum, numBits];

SELECT whichCase FROM
oneOnly => RETURN[BITAND[BITSHIFT[acw[index], -shift], mask]];

twoWords => {
ln: LongNumber;
val: WORD;
ln.lo _ acw[index+1];
ln.hi _ acw[index];
val _ Basics.ExtractWordField[ln, shift];
RETURN[Basics.BITAND[LOOPHOLE[val], mask] ];
};

ENDCASE =>
ERROR MicroDefs.Error[
IO.PutFR["\n FirstBitNum (%g) or NumBits (%g) out of range\n",
IO.card[firstBitNum], IO.card[numBits]] ];

};

WhichBitsCase: TYPE = {oneOnly, twoWords, outOfRange};

SetBits: PUBLIC PROC[acw: WordSeq, firstBitNum, numBits: INTEGER, val: WORD] = {
OPEN Basics;
mask: WORD _ MakeMask[numBits];
shift, index: NAT;
whichCase: WhichBitsCase;
valToStore: WORD = BITAND[mask, val];
[whichCase, index, shift] _ WhichBits[firstBitNum, numBits];

SELECT whichCase FROM
oneOnly => {
ln1, ln2: LongNumber;
ln1.lo _ acw[index]; ln1.hi _ 0;
ln2.lo _ mask; ln2.hi _ 0;
TRUSTED { ln1 _ DoubleAnd[ln1, DoubleNot[DoubleShiftLeft[ln2, shift]]] };
ln2.lo _ valToStore; ln2.hi _ 0;
TRUSTED { ln1 _ DoubleOr[ln1, DoubleShiftLeft[ln2, shift]] };
acw[index] _ ln1.lo;
};
twoWords => {
ln1, ln2: LongNumber;
ln1.lo _ acw[index+1]; ln1.hi _ acw[index];
ln2.lo _ mask; ln2.hi _ 0;
TRUSTED { ln1 _ DoubleAnd[ln1, DoubleNot[DoubleShiftLeft[ln2, shift]]] };
ln2.lo _ valToStore; ln2.hi _ 0;
TRUSTED { ln1 _ DoubleOr[ln1, DoubleShiftLeft[ln2, shift]] };
acw[index+1] _ ln1.lo; acw[index] _ ln1.hi;
};
ENDCASE =>
ERROR MicroDefs.Error[
IO.PutFR["\n FirstBitNum (%g) or NumBits (%g) out of range\n",
IO.card[firstBitNum], IO.card[numBits]] ];
};

WhichBits: PROC[firstBit, numBits: INTEGER]
        RETURNS[whichCase: WhichBitsCase, leftIndex, shift: NAT] = {
rightMost: INTEGER = firstBit + numBits - 1;
rightIndex: INTEGER = rightMost/16;

leftIndex _ firstBit/16;

shift _ (rightIndex+1)*16 - rightMost - 1;
IF leftIndex = rightIndex THEN whichCase _ oneOnly
ELSE IF leftIndex+1 = rightIndex THEN whichCase _ twoWords
ELSE
{whichCase _ outOfRange; leftIndex _ shift _ 0 };
};

MakeZero: PROC[acw: WordSeq] =
{ IF acw # NIL THEN FOR i: NAT IN [0..acw.length) DO acw[i] _ 0; ENDLOOP };

MakeTempZero: PROC[tmp: WordSeq] =
{ FOR i: NAT IN [0..tmp.length) DO tmp[i] _ 0; ENDLOOP };

MakeMask: PROC[num: CARDINAL] RETURNS[WORD] = {
SELECT num FROM
 0 => RETURN[0];
 1 => RETURN[1];
 2 => RETURN[3];
 3 => RETURN[7];
 4 => RETURN[17B];
 5 => RETURN[37B];
 6 => RETURN[77B];
 7 => RETURN[177B];
 8 => RETURN[377B];
 9 => RETURN[777B];
10 => RETURN[1777B];
11 => RETURN[3777B];
12 => RETURN[7777B];
13 => RETURN[17777B];
14 => RETURN[37777B];
15 => RETURN[77777B];
16 => RETURN[177777B];
ENDCASE =>
ERROR MicroDefs.Error[IO.PutFR["\nNumBits field too big (%g)\n", IO.card[num]] ];
};

END.