DIRECTORY
Alloc USING [Notifier],
Code USING [codeptr, stking, tempcontext, tempstart],
CodeDefs USING [Base, Byte, CCIndex, CCNull, codeType, EvalStackSize, LabelCCNull,Lexeme, StackIndex, StackItem, StackLocRec, StackNull, StackPos, TempAddr, VarComponent],
FOpCodes USING [qBNDCK, qDUP, qEXCH, qLLK, qNILCK, qNILCKL, qPOP],
P5 USING [GenTempLex, PopEffect, PushEffect],
P5L USING [LoadComponent, StoreComponent],
P5U USING [CreateLabel, DeleteCell, FreeChunk, GetChunk, Out0, Out1],
Stack,
Symbols USING [Base, BitAddress, ContextLevel, ctxType, lZ, seType],
SymbolOps USING [CtxLevel];

StackImpl: PROGRAM
IMPORTS LCPtr: Code, P5, P5L, P5U, SymbolOps EXPORTS Stack = BEGIN OPEN CodeDefs;

CPtr: POINTER TO FRAME [Code] = LCPtr;
cb: CodeDefs.Base;
seb, ctxb: Symbols.Base;
uBound: StackPos;

StackImplNotify: PUBLIC Alloc.Notifier =
BEGIN  -- called by allocator whenever table area is repacked
seb _ base[Symbols.seType];
ctxb _ base[Symbols.ctxType];
cb _ base[codeType];
END;

stkHead: StackIndex _ StackNull;
stkPtr: StackIndex;

StackModelingError: PUBLIC SIGNAL = CODE;

StkError: PRIVATE PROC =
BEGIN SIGNAL StackModelingError END;

Above: PUBLIC PROC [s: StackIndex, count: CARDINAL _ 1, nullOk: BOOL _ FALSE]
RETURNS [StackIndex] =
BEGIN
THROUGH [0..count) DO
IF s = StackNull THEN StkError[];
s _ cb[s].uplink;
ENDLOOP;
IF s = StackNull AND ~nullOk THEN StkError[];
RETURN [s]
END;

Also: PUBLIC PROC [
n: CARDINAL _ 1, inLink: BOOL _ FALSE, tOffset: TempAddr,
tLevel: Symbols.ContextLevel _ Symbols.lZ] =
BEGIN
s: StackIndex _ Top[n];
THROUGH [0..n) DO
IF cb[s].tag # onStack THEN StkError[];
cb[s].data _ onStack[alsoLink: inLink, tOffset: tOffset, tLevel: tLevel];
tOffset _ tOffset+1;
s _ cb[s].uplink;
ENDLOOP;
END;

Check: PUBLIC PROC [b: Byte] =
BEGIN
pusheffect: CARDINAL = P5.PushEffect[b];
popeffect: CARDINAL = P5.PopEffect[b];
extra: CARDINAL _ 0;
s: StackIndex _ stkPtr;
IF ~CPtr.stking THEN RETURN;
THROUGH [0..popeffect) DO s _ cb[s].downlink ENDLOOP;
WHILE s # stkHead DO
IF cb[s].tag = onStack THEN extra _ extra + 1;
s _ cb[s].downlink;
ENDLOOP;
IF extra + pusheffect > uBound THEN Dump[];
SELECT b FROM
FOpCodes.qNILCK => Load[Top[1],1];
FOpCodes.qNILCKL => Load[Top[2],2];
FOpCodes.qBNDCK => {Load[Top[2],2]; Decr[1]};
ENDCASE => 
BEGIN
IF popeffect # 0 THEN LoadToDepth[popeffect];
Incr[pusheffect];
END;
END;

Clear: PUBLIC PROC =
BEGIN
saveStking: BOOL = CPtr.stking;
CPtr.stking _ FALSE; -- Off[];
WHILE stkPtr # stkHead DO
WITH cb[stkPtr] SELECT FROM
inTemp, inLink => NULL;
onStack => P5U.Out0[FOpCodes.qPOP];
ENDCASE => StkError[]; -- shouldn't go over a mark
DelStackItem[stkPtr];
ENDLOOP;
CPtr.stking _ saveStking;
END;

Decr: PUBLIC PROC [count: CARDINAL _ 1] =
BEGIN
THROUGH [0..count) DO
IF cb[stkPtr].tag = mark THEN StkError[];
DelStackItem[stkPtr]; -- won't delete stkHead
ENDLOOP;
END;

DeleteToMark: PUBLIC PROC =
BEGIN
ResetToMark[]; 
DelStackItem[stkPtr];
END;

DelStackItem: PRIVATE PROC [s: StackIndex] =
BEGIN
up: StackIndex = cb[s].uplink;
down: StackIndex = cb[s].downlink;
WITH cb[s] SELECT FROM
mark =>
BEGIN
IF s = stkHead THEN StkError[]; -- fell off the end
IF CPtr.codeptr = label THEN CPtr.codeptr _ cb[label].blink;
P5U.DeleteCell[label];
END;
ENDCASE;
P5U.FreeChunk[s, StackItem.SIZE];
IF up # StackNull THEN cb[up].downlink _ down
ELSE stkPtr _ down;
cb[down].uplink _ up;
END;

Depth: PUBLIC PROC RETURNS [d: StackPos] =
BEGIN
d _ 0;
FOR s: StackIndex _ stkPtr, cb[s].downlink UNTIL s = stkHead DO
WITH cb[s] SELECT FROM
onStack => d _ d+1;
ENDCASE;
ENDLOOP;
END;

Dump: PUBLIC PROC =
BEGIN
extra: CARDINAL _ 0;
s: StackIndex _ stkPtr;
wa: CARDINAL;
savec: CodeDefs.CCIndex = CPtr.codeptr;
next: CodeDefs.CCIndex;
saveStking: BOOL = CPtr.stking;
CPtr.stking _ FALSE; -- Off[];
WHILE s # stkHead DO
WITH cb[s] SELECT FROM
onStack => IF ~alsoLink AND tLevel = Symbols.lZ THEN extra _ extra + 1;
ENDCASE;
s _ cb[s].downlink;
ENDLOOP;
IF extra # 0 THEN
BEGIN
tlex: Lexeme.se = P5.GenTempLex[extra];
a: Symbols.BitAddress = seb[tlex.lexsei].idValue;
wa _ a.wd + extra-1;
END;
s _ stkPtr;
WHILE s # stkHead DO
WITH cb[s] SELECT FROM
onStack => wa _ Store[s, wa];
mark => CPtr.codeptr _ label;
ENDCASE;
s _ cb[s].downlink;
ENDLOOP;
CPtr.codeptr _ savec;
UNTIL (next _ cb[CPtr.codeptr].flink) = CCNull DO CPtr.codeptr _ next ENDLOOP;
CPtr.stking _ saveStking;
END;

Dup: PUBLIC PROC [load: BOOL _ FALSE] =
BEGIN
oldTop: StackIndex = stkPtr;
saveStking: BOOL = CPtr.stking;
CPtr.stking _ FALSE; -- Off[];
IF Depth[]+1 > uBound THEN Dump[];
Incr[1];
WITH ss: cb[oldTop] SELECT FROM
onStack =>
BEGIN
P5U.Out0[FOpCodes.qDUP];
cb[stkPtr].data _ onStack[alsoLink: ss.alsoLink,
tOffset: ss.tOffset, tLevel: ss.tLevel];
END;
inTemp =>
BEGIN
cb[stkPtr].data _ inTemp[tOffset: ss.tOffset, tLevel: ss.tLevel];
IF load THEN LoadItem[stkPtr];
END;
inLink =>
BEGIN
cb[stkPtr].data _ inLink[link: ss.link];
IF load THEN LoadItem[stkPtr];
END;
ENDCASE => StkError[];
CPtr.stking _ saveStking;
END;

Exchange: PUBLIC PROC =
BEGIN
st1: StackIndex = stkPtr;
st2: StackIndex = cb[st1].downlink;
IF st2 = stkHead OR cb[st2].tag = mark THEN StkError[];
WITH cb[st1] SELECT FROM
onStack => Load[st2, 1];
inTemp, inLink =>
BEGIN
t: StackIndex = cb[st2].downlink;
cb[t].uplink _ st1; cb[st1].downlink _ t;
cb[st1].uplink _ st2; cb[st2].downlink _ st1;
cb[st2].uplink _ StackNull;
END;
ENDCASE => StkError[];
stkPtr _ st2;
END;

Forget: PUBLIC PROC [s: StackIndex, count: CARDINAL _ 1] =
BEGIN
next: StackIndex;
THROUGH [0..count) DO
IF s = StackNull THEN StkError[];
next _ cb[s].uplink;
DelStackItem[s];
s _ next;
ENDLOOP;
END;

Incr: PUBLIC PROC [count: CARDINAL _ 1] =
BEGIN
s: StackIndex;
THROUGH [0..count) DO
cb[stkPtr].uplink _ s _ P5U.GetChunk[StackItem.SIZE];
cb[s] _ [downlink: stkPtr, data: TRASH];
cb[s].data _ onStack[];
stkPtr _ s;
ENDLOOP;
END;

Init: PUBLIC PROC = 
BEGIN
uBound _ EvalStackSize - 2;
stkHead _ P5U.GetChunk[StackItem.SIZE];
cb[stkHead] _ [downlink: stkHead, data: mark[LabelCCNull]];
stkPtr _ stkHead;
CPtr.stking _ FALSE;
END;

KeepOnly: PUBLIC PROC [s: StackIndex, count: CARDINAL] =
BEGIN -- used when taking initial field of larger stacked record
n: CARDINAL _ 0;
THROUGH [0..count) DO
IF s = StackNull THEN StkError[];
s _ cb[s].uplink;
ENDLOOP;
WHILE s # StackNull DO
n _ n+1;
s _ cb[s].uplink;
ENDLOOP;
IF n # 0 THEN Pop[n];
END;

Load: PUBLIC PROC [s: StackIndex, count: CARDINAL _ 1] =
BEGIN
loc: StackLocRec _ Loc[s, count];
first: StackIndex = s;
last: StackIndex _ Above[first, count-1];
ts: StackIndex;
saveStking: BOOL = CPtr.stking;
CPtr.stking _ FALSE; -- Off[];
BEGIN -- to set up linkToTop label
WITH ll: loc SELECT FROM
onStack =>
BEGIN
ad: CARDINAL;
IF ll.depth = 0 THEN GO TO done;
ad _ 0;
ts _ stkPtr;
THROUGH [0..ll.depth) DO
WITH cb[ts] SELECT FROM
onStack => ad _ ad+1;
ENDCASE => NULL;
ts _ cb[ts].downlink;
ENDLOOP;
IF ad = 0 THEN GO TO linkToTop;
IF ad = 1 AND count = 1 THEN {P5U.Out0[FOpCodes.qEXCH]; GO TO linkToTop};
StoreItems[cb[last].uplink, ll.depth];
GO TO linkToTop;
END;
inTemp =>
BEGIN
IF Depth[] + count > uBound THEN Dump[];
ts _ first;
THROUGH [0..count) DO
LoadItem[ts];
ts _ cb[ts].uplink;
ENDLOOP;
GO TO linkToTop;
END;
inLink =>
BEGIN -- count = 1
IF Depth[] + 1 > uBound THEN Dump[];
LoadItem[first];
GO TO linkToTop;
END;
ENDCASE =>
BEGIN -- usually some things in temps with some loaded above
toLoad: CARDINAL _ count;
extra: CARDINAL;
ts _ first;
THROUGH [0..count) DO
IF cb[ts].tag = onStack THEN toLoad _ toLoad-1;
ts _ cb[ts].uplink;
ENDLOOP;
IF Depth[] + toLoad > uBound THEN Dump[];
IF toLoad = count-1 AND count <= 4 AND cb[last].tag = onStack THEN
BEGIN
IF ts # StackNull THEN StoreItems[ts, VDepthOf[ts]+1]; -- unlikely
ts _ first;
THROUGH [0..toLoad) DO
LoadItem[ts];
P5U.Out0[FOpCodes.qEXCH];
ts _ cb[ts].uplink;
ENDLOOP;
GO TO linkToTop;
END;
ts _ first; extra _ count;
THROUGH [0..count) DO
IF cb[ts].tag # onStack THEN EXIT;
extra _ extra-1;
ts _ cb[ts].uplink;
ENDLOOP;
StoreItems[ts, VDepthOf[ts]+1]; -- in the unlikely case stuff is above
THROUGH [0..extra) DO
LoadItem[ts];
ts _ cb[ts].uplink;
ENDLOOP;
GO TO linkToTop;
END;
EXITS
linkToTop =>
BEGIN
rest: StackIndex = Above[first, count, TRUE];
IF rest # StackNull THEN
BEGIN
down: StackIndex = cb[first].downlink;
cb[stkPtr].uplink _ first;
cb[first].downlink _ stkPtr;
cb[rest].downlink _ down;
cb[down].uplink _ rest;
cb[last].uplink _ StackNull;
stkPtr _ last;
END;
END;
done => NULL;
END;
CPtr.stking _ saveStking;
END;

LoadItem: PRIVATE PROC [s: StackIndex] =
BEGIN -- stking is off when called
off: TempAddr;
lvl: Symbols.ContextLevel;
var: VarComponent;
WITH cb[s] SELECT FROM
inTemp =>
BEGIN
off _ tOffset;
lvl _ tLevel;
END;
inLink =>
BEGIN
P5U.Out1[FOpCodes.qLLK, link];
cb[s].data _ onStack [alsoLink: TRUE, tOffset: link];
RETURN;
END;
onStack => RETURN;
ENDCASE => StkError[];
var _ [wSize: 1, space: frame[level: lvl, wd: off, immutable: TRUE]];
P5L.LoadComponent[var];
cb[s].data _ onStack[tOffset: off, tLevel: lvl];
END;

LoadToDepth: PRIVATE PROC [n: StackPos] =
BEGIN
IF n = 0 THEN RETURN;
Load[Top[n], n];
Decr[n];
END;

Loc: PUBLIC PROC [s: StackIndex, count: CARDINAL _ 1] RETURNS [StackLocRec] =
BEGIN
WITH cb[s] SELECT FROM
onStack =>
BEGIN
d: StackPos _ 0;
THROUGH (0..count) DO
s _ cb[s].uplink;
WITH cb[s] SELECT FROM
onStack => NULL;
mark => StkError[];
ENDCASE => RETURN [[mixed[]]];
ENDLOOP;
WHILE s # stkPtr DO d _ d+1; s _ cb[s].uplink ENDLOOP;
RETURN [[onStack[d]]];
END;
inTemp => 
BEGIN
lvl: Symbols.ContextLevel _ tLevel;
off: TempAddr _ tOffset;
FOR i: CARDINAL IN (0..count) DO
s _ cb[s].uplink;
WITH cb[s] SELECT FROM
inTemp => IF tLevel # lvl OR tOffset # off+i THEN RETURN [[mixed[]]];
mark => StkError[];
ENDCASE => RETURN [[mixed[]]];
ENDLOOP;
RETURN [[inTemp[tSize: count, tLevel: lvl, tOffset: off]]];
END;
inLink => RETURN [IF count # 1 THEN [mixed[]] ELSE [inLink[link]]];
ENDCASE => StkError[]; -- shouldn't be a mark
ERROR; -- Since compiler doesn't know StkError doesn't return
END;

Mark: PUBLIC PROC =
BEGIN
down: StackIndex = stkPtr;
stkPtr _ P5U.GetChunk[StackItem.SIZE];
cb[stkPtr] _ [downlink: down, data: mark[P5U.CreateLabel[]]];
cb[down].uplink _ stkPtr;
END;

MoveToTemp: PUBLIC PROC [firstIndex: StackIndex, count: CARDINAL _ 1]
RETURNS [VarComponent] =
BEGIN -- store "count" words from stack into contiguous temps
s: StackIndex;
tStart, tempPrev: TempAddr;
ctlvl: Symbols.ContextLevel = SymbolOps.CtxLevel[CPtr.tempcontext];
lvlPrev: Symbols.ContextLevel;
first: BOOL _ TRUE;
remaining: CARDINAL _ count;
saveStking: BOOL = CPtr.stking;
above: StackIndex = Above[s: firstIndex, count: count, nullOk: TRUE];

PutBackJunk: PROC =
BEGIN
cb[stkPtr].uplink _ above;
cb[above].downlink _ stkPtr;
UNTIL cb[stkPtr].uplink = StackNull DO stkPtr _ cb[stkPtr].uplink ENDLOOP;
END;

CPtr.stking _ FALSE; -- Stack.Off[];
IF above # StackNull THEN
BEGIN -- unlikely
n: StackPos = VDepthOf[above];
IF cb[above].tag # mark --AND n # 0 -- THEN StoreItems[above, n+1];	-- ??? (EHS)
stkPtr _ cb[above].downlink;
cb[stkPtr].uplink _ StackNull; -- temporarily unlink
END;
IF count = 1 THEN
BEGIN -- trade space for clarity
var: VarComponent;
WITH cb[firstIndex] SELECT FROM
onStack => StoreItems[firstIndex, 1];
ENDCASE;
WITH cb[firstIndex] SELECT FROM
inTemp => var _ [wSize: 1, space:
frame[wd: tOffset, immutable: TRUE, level: tLevel]];
inLink => var _ [wSize: 1, space: link[wd: link]];
ENDCASE;
DelStackItem[firstIndex];
CPtr.stking _ saveStking;
IF above # StackNull THEN PutBackJunk[];
RETURN[var]
END;

BEGIN -- to set up moveRest label
BEGIN -- to set up moveAll label
FOR s _ firstIndex, cb[s].uplink WHILE s # StackNull DO
WITH ss: cb[s] SELECT FROM
inTemp => 
BEGIN
IF first THEN
BEGIN
tStart _ ss.tOffset;
lvlPrev _ ss.tLevel;
first _ FALSE;
END
ELSE
BEGIN
IF ss.tLevel # lvlPrev OR ss.tOffset # tempPrev+1 THEN
GO TO moveAll; -- not worth a check for hole after prev
END;
tempPrev _ ss.tOffset;
remaining _ remaining-1;
END;
inLink => GO TO moveAll;
onStack =>
BEGIN
IF ss.tLevel # Symbols.lZ THEN
BEGIN
IF first THEN
BEGIN
tStart _ tempPrev _ ss.tOffset;
lvlPrev _ ss.tLevel;
first _ FALSE;
END
ELSE
BEGIN
IF ss.tLevel # lvlPrev OR ss.tOffset # tempPrev+1 THEN
GO TO moveAll; -- not worth a check for hole after prev
END;
tempPrev _ ss.tOffset;
remaining _ remaining-1;
END
ELSE IF first OR lvlPrev # ctlvl OR tempPrev # CPtr.tempstart-1 THEN
GO TO moveAll
ELSE GO TO moveRest;
END;
ENDCASE => StkError[];
ENDLOOP;
EXITS
moveAll =>
BEGIN
remaining _ count;
tStart _ CPtr.tempstart;
lvlPrev _ ctlvl;
GO TO moveRest;
END;
END;
EXITS
moveRest =>
BEGIN
tlex: Lexeme.se = P5.GenTempLex[remaining];
a: Symbols.BitAddress = seb[tlex.lexsei].idValue;
wa: CARDINAL _ a.wd + remaining - 1;
THROUGH [0..remaining) DO -- fix someday to look for doubles
LoadItem[stkPtr];
wa _ Store[stkPtr, wa, TRUE];
DelStackItem[stkPtr]; -- this updates stkPtr
ENDLOOP;
END;
END;

IF remaining < count THEN Pop[count-remaining];
CPtr.stking _ saveStking;
IF above # StackNull THEN PutBackJunk[];
RETURN [[wSize: count, space: frame[wd: tStart, immutable: TRUE, level: lvlPrev]]];
END;

New: PUBLIC PROC RETURNS [old: StackIndex] =
BEGIN
old _ cb[stkHead].uplink;
cb[stkHead].uplink _ StackNull;
stkPtr _ stkHead;
END;

Off: PUBLIC PROC = {CPtr.stking _ FALSE};

On: PUBLIC PROC = {CPtr.stking _ TRUE};

Pop: PUBLIC PROC [count: CARDINAL _ 1] =
BEGIN
saveStking: BOOL = CPtr.stking;
s, next: StackIndex;
CPtr.stking _ FALSE; -- Off[];
FOR s _ stkPtr, next WHILE count > 0 DO
next _ cb[s].downlink;
SELECT cb[s].tag FROM
onStack, inTemp, inLink =>
BEGIN
IF cb[s].tag = onStack THEN P5U.Out0[FOpCodes.qPOP];
count _ count - 1; DelStackItem[s];
END;
mark => NULL;
ENDCASE => StkError[];
ENDLOOP;
CPtr.stking _ saveStking;
END;

Prefix: PUBLIC PROC [sti: StackIndex] =
BEGIN
ts, bs: StackIndex;
IF sti = StackNull THEN RETURN;
FOR ts _ sti, cb[ts].uplink UNTIL cb[ts].uplink = StackNull DO
ENDLOOP;
bs _ cb[stkHead].uplink;
cb[ts].uplink _ bs;
IF bs = StackNull THEN stkPtr _ ts ELSE cb[bs].downlink _ ts;
cb[stkHead].uplink _ sti; cb[sti].downlink _ stkHead;
END;

Require: PUBLIC PROC [n: StackPos] =
BEGIN
extra: CARDINAL _ 0;
s: StackIndex _ stkPtr;
THROUGH [0..n) DO s _ cb[s].downlink ENDLOOP;
WHILE s # stkHead DO
IF cb[s].tag = onStack THEN extra _ extra + 1;
s _ cb[s].downlink;
ENDLOOP;
IF extra # 0 THEN Dump[];
END;

Reset: PUBLIC PROC =
BEGIN
WHILE stkPtr # stkHead DO DelStackItem[stkPtr] ENDLOOP;
END;

ResetToMark: PUBLIC PROC =
BEGIN
n: CARDINAL _ 0;
FOR s: StackIndex _ stkPtr, cb[s].downlink DO
WITH cb[s] SELECT FROM
mark => IF s = stkHead THEN StkError[] ELSE EXIT;
ENDCASE => n _ n+1;
ENDLOOP;
IF n # 0 THEN LoadToDepth[n];
END;

Restore: PUBLIC PROC [s: StackIndex] =
BEGIN
Reset[]; -- free all but head
cb[stkHead].uplink _ s;
stkPtr _ stkHead;
UNTIL s = StackNull DO
stkPtr _ s;
s _ cb[stkPtr].uplink;
ENDLOOP;
END;

RoomFor: PUBLIC PROC [n: CARDINAL] RETURNS [BOOL] =
BEGIN
RETURN [Depth[]+n <= uBound]
END;

Store: PRIVATE PROC [
s: StackIndex,
addr: TempAddr,
storeNew: BOOL _ FALSE] RETURNS [nextAddr: TempAddr] =
BEGIN -- stack is off when called
lvl: Symbols.ContextLevel;
off: TempAddr;
link: BOOL;
BEGIN -- to set up label: store
WITH cb[s] SELECT FROM
onStack => IF storeNew OR ~(alsoLink OR tLevel # Symbols.lZ) THEN
GO TO store
ELSE
BEGIN
P5U.Out0[FOpCodes.qPOP];
lvl _ tLevel; off _ tOffset; link _ alsoLink;
END;
inTemp, inLink => RETURN;
ENDCASE => StkError[];
EXITS
store =>
BEGIN
link _ FALSE;
off _ addr;
lvl _ SymbolOps.CtxLevel[CPtr.tempcontext];
StoreWord[addr, lvl];
addr _ addr-1;
END;
END;
IF link THEN cb[s].data _ inLink[off]
ELSE cb[s].data _ inTemp[tOffset: off, tLevel: lvl];
RETURN[addr];
END;

StoreItems: PRIVATE PROC [start: StackIndex, count: CARDINAL] =
BEGIN -- not necessarily contiguously
needed: CARDINAL _ 0;
s, last: StackIndex;
wa: CARDINAL;

s _ start;
THROUGH [0..count) DO
IF s = StackNull THEN StkError[];
WITH ss: cb[s] SELECT FROM
inTemp, inLink => NULL;
onStack => IF ~(ss.alsoLink OR ss.tLevel # Symbols.lZ) THEN needed _ needed+1;
ENDCASE => StkError[];
last _ s;
s _ cb[s].uplink;
ENDLOOP;

IF needed # 0 THEN
BEGIN
tlex: Lexeme.se _ P5.GenTempLex[needed];
a: Symbols.BitAddress _ seb[tlex.lexsei].idValue;
wa _ a.wd + needed - 1;
END;

s _ last;
THROUGH [0..count) DO
WITH cb[s] SELECT FROM
inTemp, inLink => NULL;
onStack => wa _ Store[s, wa, FALSE];
ENDCASE;
s _ cb[s].downlink;
ENDLOOP;
END;

StoreWord: PRIVATE PROC [offset: TempAddr, lvl: Symbols.ContextLevel] =
BEGIN
var: VarComponent = [wSize: 1, space: frame[wd: offset, level: lvl]];
P5L.StoreComponent[var];
END;

TempStore: PUBLIC PROC [count: CARDINAL _ 1] RETURNS [VarComponent] =
BEGIN -- store top of stack into contiguous temps
RETURN [MoveToTemp[Top[count], count]];
END;

Top: PUBLIC PROC [count: CARDINAL _ 1] RETURNS [s: StackIndex] =
BEGIN
s _ stkPtr;
THROUGH (0..count) DO s _ cb[s].downlink ENDLOOP;
IF s = stkHead THEN StkError[];
RETURN
END;

UnMark: PUBLIC PROC =
BEGIN
n: CARDINAL _ 0;
FOR s: StackIndex _ stkPtr, cb[s].downlink DO
WITH cb[s] SELECT FROM
mark =>
BEGIN
IF s = stkHead THEN StkError[]; -- fell off the end
DelStackItem[s];
LoadToDepth[n]; -- make sure loaded, also forget from where
Incr[n]; -- remember how many things loaded
RETURN
END;
ENDCASE => n _ n+1;
ENDLOOP;
END;

VDepth: PUBLIC PROC RETURNS [StackPos] =
BEGIN
RETURN [VDepthOf[stkHead]];
END;

VDepthOf: PUBLIC PROC [s: StackIndex] RETURNS [d: StackPos] =
BEGIN
d _ 0;
IF s = StackNull THEN StkError[];
DO
s _ cb[s].uplink;
IF s = StackNull THEN RETURN;
IF cb[s].tag # mark THEN d _ d+1;
ENDLOOP;
END;

END.


2StackImpl.mesa  
Copyright c 1985 by Xerox Corporation.  All rights reserved.
Sweet,  February 3, 1981  4:54 PM
Satterthwaite, April 21, 1986 4:41:48 pm PST
Russ Atkinson (RRA) March 6, 1985 11:25:54 pm PST
Store the top element at addr 
if storeNew = FALSE and in memory, then generate POP instead
Κ%˜
codeš
œ™Kšœ
Οm
œ1™<Kš
œ!™!Kš
œ,™,K™1—K˜š
Οk	˜	Kšœžœ˜Kšœžœ+˜5Kšœ	žœ
˜«
Kšœ	žœ4˜BKšœžœ%˜-Kšœžœ!˜*Kšœžœ<˜EKš
œ˜Kšœžœ7˜DKšœ
žœ˜K˜—šœž˜Kš
žœžœ	žœžœ
žœ
˜QK˜Kšœžœ
žœ
žœ˜&K˜K˜K˜K˜šœžœ˜(KšžœΟc6˜=K˜K˜K˜Kšžœ
˜K˜—K˜ K˜K˜Kšœžœ
žœžœ
˜)K˜šΟnœžœ
žœ˜Kšžœ
žœžœ
˜$K˜—š œžœ
žœžœžœžœ
˜MKšžœ˜Kš
ž˜šžœž˜Kšžœžœ˜!K˜Kšžœ
˜—Kšžœžœ	žœ˜-Kšžœ˜
Kšžœ
˜K˜—š œžœ
žœ˜Kšœžœžœžœ˜9K˜,Kš
ž˜K˜šžœž˜Kšžœžœ˜'K˜IK˜K˜Kšžœ
˜—Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜Kšœžœ˜(Kšœžœ˜&Kšœžœ˜K˜Kšžœžœ
žœ
˜Kšžœžœžœ
˜5šžœ
ž˜Kšžœžœ˜.K˜Kšžœ
˜—Kšžœžœ˜+šžœž˜
K˜"K˜#K˜-šžœ˜Kš
ž˜Kšžœžœ˜-K˜Kšžœ
˜——Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜Kšœžœ˜KšœžœŸ	˜šžœž˜šžœžœ
ž˜Kšœžœ
˜K˜#KšžœŸ˜2—K˜Kšžœ
˜—K˜Kšžœ
˜K˜—š œžœ
žœ	žœ˜)Kš
ž˜šžœž˜Kšžœžœ˜)KšœŸ˜-Kšžœ
˜—Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜K˜K˜Kšžœ
˜K˜—š œžœ
žœ˜,Kš
ž˜K˜K˜"šžœžœ
ž˜˜Kš
ž˜Kšžœ
žœ
Ÿ˜3Kšžœžœ ˜<K˜Kšžœ
˜—Kšžœ
˜—Kšœžœ˜!Kšžœžœ˜-Kšžœ˜K˜Kšžœ
˜K˜—š œžœ
žœ
žœ˜*Kš
ž˜K˜šžœ(žœ
ž˜?šžœžœ
ž˜K˜Kšžœ
˜—Kšžœ
˜—Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜Kšœžœ˜K˜Kšœžœ
˜
K˜'K˜Kšœžœ˜KšœžœŸ	˜šžœ
ž˜šžœžœ
ž˜Kšœžœžœžœ˜GKšžœ
˜—K˜Kšžœ
˜—šžœž˜Kš
ž˜K˜'K˜1K˜Kšžœ
˜—K˜šžœ
ž˜šžœžœ
ž˜K˜K˜Kšžœ
˜—K˜Kšžœ
˜—K˜Kšžœ*žœžœ
˜NK˜Kšžœ
˜K˜—š
 œžœ
žœžœžœ˜'Kš
ž˜K˜Kšœžœ˜KšœžœŸ	˜Kšžœžœ˜"K˜šžœžœ
ž˜˜
Kš
ž˜K˜˜0K˜(—Kšžœ
˜—˜	Kš
ž˜K˜AKšžœžœ˜Kšžœ
˜—˜	Kš
ž˜K˜(Kšžœžœ˜Kšžœ
˜—Kšžœ˜—K˜Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜K˜K˜#Kšžœžœžœ˜7šžœ	žœ
ž˜K˜˜Kš
ž˜K˜!K˜)K˜-K˜Kšžœ
˜—Kšžœ˜—K˜
Kšžœ
˜K˜—š œžœ
žœžœ˜:Kš
ž˜K˜šžœž˜Kšžœžœ˜!K˜K˜K˜	Kšžœ
˜—Kšžœ
˜K˜—š œžœ
žœ	žœ˜)Kš
ž˜K˜šžœž˜Kšœ/žœ˜5Kšœ!žœ˜(K˜K˜Kšžœ
˜—Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜K˜Kšœ!žœ˜'K˜;K˜Kšœžœ
˜Kšžœ
˜K˜—š œžœ
žœžœ˜8Kšžœ
Ÿ:˜@Kšœžœ˜šžœž˜Kšžœžœ˜!K˜Kšžœ
˜—šžœž˜K˜K˜Kšžœ
˜—Kšžœžœ˜Kšžœ
˜K˜—š œžœ
žœžœ˜8Kš
ž˜K˜!K˜K˜)K˜Kšœžœ˜KšœžœŸ	˜Kšžœ
Ÿ˜"šžœ	žœ
ž˜˜
Kš
ž˜Kšœžœ
˜
Kšžœžœ
žœ
žœ˜ K˜K˜šžœž˜šžœžœ
ž˜K˜Kšžœžœ
˜—K˜Kšžœ
˜—Kšžœžœ
žœ
žœ˜Kš
žœžœžœžœ
žœ˜IK˜&Kšžœ
žœ˜Kšžœ
˜—˜	Kš
ž˜Kšžœžœ˜(K˜šžœž˜K˜
K˜Kšžœ
˜—Kšžœ
žœ˜Kšžœ
˜—˜	Kšžœ
Ÿ˜Kšžœžœ˜$K˜Kšžœ
žœ˜Kšžœ
˜—šžœ˜
Kšžœ
Ÿ6˜<Kšœžœ	˜Kšœžœ
˜K˜šžœž˜Kšžœžœ˜/K˜Kšžœ
˜—Kšžœžœ˜)šžœžœžœž˜BKš
ž˜Kšžœžœ!Ÿ˜BK˜šžœ
ž˜K˜
K˜K˜Kšžœ
˜—Kšžœ
žœ˜Kšžœ
˜—K˜šžœž˜Kšžœžœ
žœ
˜"K˜K˜Kšžœ
˜—Kšœ Ÿ&˜Fšžœž˜K˜
K˜Kšžœ
˜—Kšžœ
žœ˜Kšžœ
˜——š
ž˜˜Kš
ž˜Kšœ'žœ˜-šžœž˜Kš
ž˜K˜&K˜K˜K˜K˜K˜K˜Kšžœ
˜—Kšžœ
˜—Kšœžœ
˜
—Kšžœ
˜K˜Kšžœ
˜K˜—š œžœ
žœ˜(Kšžœ
Ÿ˜"K˜K˜K˜šžœžœ
ž˜˜	Kš
ž˜K˜K˜
Kšžœ
˜—˜	Kš
ž˜K˜Kšœ žœ˜5Kšžœ
˜Kšžœ
˜—Kšœžœ
˜Kšžœ˜—Kšœ>žœ˜EK˜K˜0Kšžœ
˜K˜—š œžœ
žœ˜)Kš
ž˜Kšžœžœ
žœ
˜K˜K˜Kšžœ
˜K˜—š
 œžœ
žœžœžœ˜MKš
ž˜šžœžœ
ž˜˜
Kš
ž˜K˜šžœž˜K˜šžœžœ
ž˜Kšœžœ
˜K˜Kšžœžœ
˜—Kšžœ
˜—Kšžœžœžœ
˜6Kšžœ˜Kšžœ
˜—˜
Kš
ž˜K˜#K˜šžœžœ
žœž˜ K˜šžœžœ
ž˜Kš	œ
žœžœžœ
žœ
˜EK˜Kšžœžœ
˜—Kšžœ
˜—Kšžœ5˜;Kšžœ
˜—Kš	œ
žœžœžœžœ˜CKšžœŸ˜-—KšžœŸ6˜=Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜K˜Kšœ žœ˜&K˜=K˜Kšžœ
˜K˜—š 
œžœ
žœ!žœ˜EKšžœ˜Kšžœ
Ÿ7˜=K˜K˜K˜CK˜Kšœžœžœ
˜Kšœžœ	˜Kšœžœ˜Kšœ?žœ˜EK˜š œžœ˜Kš
ž˜K˜K˜Kšžœžœžœ
˜JKšžœ
˜K˜—KšœžœŸ˜$šžœž˜Kšžœ
Ÿ˜K˜KšžœŸœ
žœŸ˜PK˜KšœŸ˜4Kšžœ
˜—šžœž˜Kšžœ
Ÿ˜ K˜šžœžœ
ž˜K˜%Kšžœ
˜—šžœžœ
ž˜˜!Kšœžœ˜4—K˜2Kšžœ
˜—K˜K˜Kšžœžœ˜(Kšžœ˜Kšžœ
˜K˜—Kšžœ
Ÿ˜!Kšžœ
Ÿ˜ šžœžœž˜7šžœžœ
ž˜˜
Kš
ž˜šžœž˜
Kš
ž˜K˜K˜Kšœžœ
˜Kš
ž˜—š
ž˜Kš
ž˜šžœžœž˜6Kšžœ
žœ
Ÿ(˜7—Kšžœ
˜—K˜K˜Kšžœ
˜—Kšœ
žœ
žœ	˜˜
Kš
ž˜šžœž˜Kš
ž˜šžœž˜
Kš
ž˜K˜K˜Kšœžœ
˜Kš
ž˜—š
ž˜Kš
ž˜šžœžœž˜6Kšžœ
žœ
Ÿ(˜7—Kšžœ
˜—K˜K˜Kš
ž˜—šžœžœžœž˜DKšžœ
žœ˜
—Kšžœ
žœ
˜Kšžœ
˜—Kšžœ˜—Kšžœ
˜—š
ž˜˜
Kš
ž˜K˜K˜K˜Kšžœ
žœ
˜Kšžœ
˜——Kšžœ
˜š
ž˜˜Kš
ž˜K˜+K˜1Kšœžœ˜$šžœžœ
Ÿ"˜<K˜Kšœžœ˜KšœŸ˜,Kšžœ
˜—Kšžœ
˜——Kšžœ
˜K˜Kšžœžœ˜/K˜Kšžœžœ˜(Kšžœ5žœ˜SKšžœ
˜K˜—š œžœ
žœ
žœ˜,Kš
ž˜K˜K˜K˜Kšžœ
˜K˜—Kš œžœ
žœžœ˜)K˜Kš œžœ
žœžœ˜'K˜š œžœ
žœ	žœ˜(Kš
ž˜Kšœžœ˜K˜KšœžœŸ	˜šžœžœž˜'K˜šžœž˜˜Kš
ž˜Kšžœžœ˜4K˜#Kšžœ
˜—Kšœžœ
˜
Kšžœ˜—Kšžœ
˜—K˜Kšžœ
˜K˜—š œžœ
žœ˜'Kš
ž˜K˜Kšžœžœ
žœ
˜šžœžœž˜>Kšžœ
˜—K˜K˜Kšžœžœ
žœ˜=K˜5Kšžœ
˜K˜—š œžœ
žœ˜$Kš
ž˜Kšœžœ˜K˜Kšžœžœžœ
˜-šžœ
ž˜Kšžœžœ˜.K˜Kšžœ
˜—Kšžœžœ˜Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜Kšžœžœžœ
˜7Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜Kšœžœ˜šžœ(ž˜-šžœžœ
ž˜Kš	œžœ
žœžœ
žœ
˜1Kšžœ˜—Kšžœ
˜—Kšžœžœ˜Kšžœ
˜K˜—š œžœ
žœ˜&Kš
ž˜Kšœ	Ÿ˜K˜K˜šžœž˜K˜K˜Kšžœ
˜—Kšžœ
˜K˜—š œžœ
žœžœžœžœ˜3Kš
ž˜Kšžœ˜Kšžœ
˜K˜—š œžœ
žœ˜K˜K˜Kšœ
žœžœžœ˜6Kšžœ
Ÿ˜!Kš
œ™Kš
œ<™<K˜K˜Kšœžœ
˜Kšžœ
Ÿ˜šžœžœ
ž˜šœžœ
žœžœž˜AKšžœ
žœ˜š
ž˜Kš
ž˜K˜K˜-Kšžœ
˜——Kšœžœ
˜Kšžœ˜—š
ž˜˜Kš
ž˜Kšœžœ
˜
K˜K˜+K˜K˜Kšžœ
˜——Kšžœ
˜Kšžœžœ˜%Kšžœ0˜4Kšžœ˜
Kšžœ
˜K˜—š 
œžœ
žœžœ˜?Kšžœ
Ÿ˜%Kšœžœ˜K˜Kšœžœ
˜
K˜K˜
šžœž˜Kšžœžœ˜!šžœžœ
ž˜Kšœžœ
˜Kšœžœžœžœ˜NKšžœ˜—K˜	K˜Kšžœ
˜K˜—šžœž˜Kš
ž˜K˜(K˜1K˜Kšžœ
˜K˜—K˜	šžœž˜šžœžœ
ž˜Kšœžœ
˜Kšœžœ˜$Kšžœ
˜—K˜Kšžœ
˜—Kšžœ
˜K˜—š 	œžœ
žœ0˜GKš
ž˜K˜EK˜Kšžœ
˜K˜—š
 	œžœ
žœ	žœžœ˜EKšžœ
Ÿ+˜1Kšžœ!˜'Kšžœ
˜K˜—š
 œžœ
žœ	žœžœ˜@Kš
ž˜K˜Kšžœžœžœ
˜1Kšžœ
žœ˜Kš
ž˜Kšžœ
˜K˜—š œžœ
žœ˜Kš
ž˜Kšœžœ˜šžœ(ž˜-šžœžœ
ž˜˜Kš
ž˜Kšžœ
žœ
Ÿ˜3K˜KšœŸ+˜;Kšœ	Ÿ"˜+Kš
ž˜Kšžœ
˜—Kšžœ˜—Kšžœ
˜—Kšžœ
˜K˜—š œžœ
žœ
žœ
˜(Kš
ž˜Kšžœ˜Kšžœ
˜K˜—š œžœ
žœžœ˜=Kš
ž˜K˜Kšžœžœ˜!š
ž˜K˜Kšžœžœ
žœ
˜Kšžœžœ	˜!Kšžœ
˜—Kšžœ
˜K˜—Kšžœ
˜K˜——…—D0_‡