
<<StackImpl.mesa  >>
<<Edited by Sweet, 5-Mar-82 21:15:48>>
<<Edited by Satterthwaite, April 18, 1986 2:17:48 pm PST>>

DIRECTORY
Alloc: TYPE USING [Notifier],
Code: TYPE USING [codeptr, tempcontext, tempstart, warnStackOverflow],
CodeDefs: TYPE USING [
Base, BYTE, CCIndex, codeType, DataStackIndex, EvalStackSize, LabelCCNull,
Lexeme, StackBackup, StackIndex, StackItem, StackLocRec, StackNull, StackPos,
TempAddr, VarComponent],
FOpCodes: TYPE USING [
qBNDCK, qDDUP, qDEXCH, qDIS, qDUP, qEXCH, qLI, qLLK, qNILCK, qNILCKL],
Log: TYPE USING [Warning],
P5: TYPE USING [GenTempLex, PopEffect, PushEffect],
P5L: TYPE USING [LoadComponent, StoreComponent],
P5U: TYPE USING [CreateLabel, DeleteCell, FreeChunk, GetChunk, Out0, Out1],
Stack: TYPE USING [],
Symbols: TYPE USING [Base, BitAddress, ContextLevel, ctxType, lZ, seType],
SymbolOps: TYPE USING [CtxLevel];

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

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;

stking: PUBLIC BOOL;
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 [place: StackBackup, n: CARDINAL_1] =
BEGIN
s: StackIndex _ Top[n];
fp: POINTER TO StackBackup.frame;
forget: BOOL _ FALSE;
IF n = 1 THEN {
WITH ss: cb[s] SELECT FROM
data => ss.backup _ place;
ENDCASE => StkError[];
RETURN};
WITH pp: place SELECT FROM
frame => fp _ @pp;
none => forget _ TRUE;
ENDCASE => StkError[];
THROUGH [0..n) DO
WITH ss: cb[s] SELECT FROM
data => ss.backup _ place;
ENDCASE => StkError[];
IF ~forget THEN fp.tOffset _ fp.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;
THROUGH [0..popeffect) DO s _ cb[s].downlink ENDLOOP;
WHILE s # stkHead DO
WITH ss: cb[s] SELECT FROM
data => IF ss.loaded THEN extra _ extra + 1;
ENDCASE;
s _ cb[s].downlink;
ENDLOOP;
IF extra + pusheffect > uBound THEN DumpAndComplain[];
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 = stking;
stking _ FALSE; -- Off[];
WHILE stkPtr # stkHead DO
WITH cc: cb[stkPtr] SELECT FROM
data => IF cc.loaded THEN P5U.Out0[FOpCodes.qDIS];
ENDCASE => StkError[]; -- shouldn't go over a mark
DelStackItem[stkPtr];
ENDLOOP;
stking _ saveStking;
END;

ComponentForBackup: PUBLIC PROC [sb: StackBackup, words: CARDINAL_1] RETURNS [VarComponent] =
BEGIN
WITH bb: sb SELECT FROM
frame => RETURN [[wSize: words, space: 
frame[wd: bb.tOffset, level: bb.tLevel, immutable: TRUE]]];
link => 
IF words # 1 THEN StkError[] 
ELSE RETURN [[wSize: 1, space: link[bb.link]]];
const => 
IF words # 1 THEN StkError[] 
ELSE RETURN [[wSize: 1, space: const[d1: bb.value]]];
ENDCASE => StkError[];
ERROR; -- can't get here, but it makes the compiler happy
END;

DataIndex: PUBLIC PROC [s: StackIndex] RETURNS [DataStackIndex] =
BEGIN
IF s = StackNull THEN RETURN[LOOPHOLE[s]];
WITH cb[s] SELECT FROM
data => RETURN [LOOPHOLE[s]];
ENDCASE => StkError[];
ERROR; -- to remove compiler warning
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 (which is mark anyway)
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 ss: cb[s] SELECT FROM
mark =>
BEGIN
IF s = stkHead THEN StkError[]; -- fell off the end
IF CPtr.codeptr = ss.label THEN CPtr.codeptr _ cb[ss.label].blink;
P5U.DeleteCell[ss.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 ss: cb[s] SELECT FROM
data => IF ss.loaded THEN d _ d+1;
ENDCASE;
ENDLOOP;
END;

Dump: PUBLIC PROC =
BEGIN
extra: CARDINAL _ 0;
s: StackIndex _ stkPtr;
wa: CARDINAL;
savec: CodeDefs.CCIndex = CPtr.codeptr;
target: CodeDefs.CCIndex = cb[savec].flink;
next: CodeDefs.CCIndex;
saveStking: BOOL = stking;
stking _ FALSE; -- Off[];
WHILE s # stkHead DO
WITH ss: cb[s] SELECT FROM
data => IF ss.backup.where = none 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 ss: cb[s] SELECT FROM
data => IF ss.loaded THEN wa _ Store[s, wa];
mark => CPtr.codeptr _ ss.label;
ENDCASE;
s _ cb[s].downlink;
ENDLOOP;
CPtr.codeptr _ savec;
UNTIL (next _ cb[CPtr.codeptr].flink) = target DO
CPtr.codeptr _ next;
ENDLOOP;
stking _ saveStking;
END;

DumpAndComplain: PRIVATE PROC = {
Dump[];
IF CPtr.warnStackOverflow THEN Log.Warning[other--awfulCode--]};

Dup: PUBLIC PROC [load: BOOL_FALSE] =
BEGIN
oldTop: DataStackIndex = DataIndex[stkPtr];
ds: DataStackIndex;
saveStking: BOOL = stking;
stking _ FALSE; -- Off[];
IF Depth[]+1 > uBound THEN DumpAndComplain[];
Incr[1]; ds _ LOOPHOLE[stkPtr]; -- Incr adds data ones
cb[ds].backup _ cb[oldTop].backup;
IF cb[oldTop].loaded THEN P5U.Out0[FOpCodes.qDUP]
ELSE {
cb[ds].loaded _ FALSE;
IF cb[oldTop].backup.where = none THEN StkError[]
ELSE IF load THEN LoadItem[stkPtr]};
stking _ saveStking;
END;

DDup: PUBLIC PROC [load: BOOL_FALSE] =
BEGIN
old2: DataStackIndex = DataIndex[stkPtr];
old1: DataStackIndex = DataIndex[cb[old2].downlink];
ds1, ds2: DataStackIndex;
saveStking: BOOL = stking;
stking _ FALSE; -- Off[];
IF Depth[]+2 > uBound THEN DumpAndComplain[];
Incr[1]; ds1 _ LOOPHOLE[stkPtr]; -- Incr adds data ones
Incr[1]; ds2 _ LOOPHOLE[stkPtr];
cb[ds1].backup _ cb[old1].backup;
cb[ds2].backup _ cb[old2].backup;
IF cb[old1].loaded AND cb[old2].loaded THEN P5U.Out0[FOpCodes.qDDUP]
ELSE {
cb[ds1].loaded _ FALSE;
cb[ds2].loaded _ FALSE;
IF load THEN {LoadItem[ds1]; LoadItem[ds2]}};
stking _ saveStking;
END;

Exchange: PUBLIC PROC =
BEGIN
st1: DataStackIndex = DataIndex[stkPtr];
st2: DataStackIndex = DataIndex[cb[st1].downlink];
IF cb[st1].loaded THEN Load[st2, 1]
ELSE
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;
stkPtr _ st2;
END;
END;

DExchange: PUBLIC PROC =
BEGIN
st1: DataStackIndex = DataIndex[stkPtr];
st2: DataStackIndex = DataIndex[cb[st1].downlink];
st3: DataStackIndex = DataIndex[cb[st2].downlink];
st4: DataStackIndex = DataIndex[cb[st3].downlink];
IF cb[st1].loaded OR cb[st2].loaded THEN Load[st3, 2]
ELSE
BEGIN
t: StackIndex = cb[st4].downlink;
cb[t].uplink _ st2; cb[st2].downlink _ t;
cb[st1].uplink _ st4; cb[st4].downlink _ st1;
cb[st3].uplink _ StackNull;
stkPtr _ st3;
END;
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, info: data[]];
stkPtr _ s;
ENDLOOP;
END;

Init: PUBLIC PROC = 
BEGIN
uBound _ EvalStackSize - 1; -- might want to store into temp outside first page
stkHead _ P5U.GetChunk[StackItem.SIZE];
cb[stkHead] _ [downlink: stkHead, info: mark[LabelCCNull]];
stkPtr _ stkHead;
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: DataStackIndex = DataIndex[s];
last: DataStackIndex _ DataIndex[Above[first, count-1]];
ts: StackIndex;
saveStking: BOOL = stking;
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 ss: cb[ts] SELECT FROM
data => IF ss.loaded THEN 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};
IF ad = 2 AND count = 2 THEN {P5U.Out0[FOpCodes.qDEXCH]; GO TO linkToTop};
StoreItems[cb[last].uplink, ll.depth];
GO TO linkToTop;
END;
contig, stored =>
BEGIN
IF Depth[] + count > uBound THEN DumpAndComplain[];
ts _ first;
THROUGH [0..count) DO
LoadItem[ts];
ts _ cb[ts].uplink;
ENDLOOP;
GO TO linkToTop;
END;
ENDCASE =>
BEGIN -- usually some things in temps with some loaded above
toLoad: CARDINAL _ count;
extra: CARDINAL;
xs: StackIndex _ first;
ds: DataStackIndex;
THROUGH [0..count) DO
ds _ DataIndex[xs];
IF cb[ds].loaded THEN toLoad _ toLoad-1;
xs _ cb[ds].uplink;
ENDLOOP;
IF Depth[] + toLoad > uBound THEN DumpAndComplain[];
IF toLoad = count-1 AND count <= 3 AND cb[last].loaded
AND ds # StackNull THEN
BEGIN
ts _ first;
THROUGH [0..toLoad) DO
LoadItem[ts];
P5U.Out0[FOpCodes.qEXCH];
ts _ cb[ts].uplink;
ENDLOOP;
GO TO linkToTop;
END;
IF toLoad = count-2 AND count <= 6 AND count MOD 2 = 0 
AND cb[last].loaded 
AND cb[LOOPHOLE[cb[last].downlink, DataStackIndex]].loaded
AND ds # StackNull THEN
BEGIN
ts _ first;
THROUGH [0..toLoad/2) DO
LoadItem[ts];
ts _ cb[ts].uplink;
LoadItem[ts];
P5U.Out0[FOpCodes.qDEXCH];
ts _ cb[ts].uplink;
ENDLOOP;
GO TO linkToTop;
END;
xs _ first; extra _ count;
THROUGH [0..count) DO
ds _ DataIndex[xs];
IF ~cb[ds].loaded THEN EXIT;
extra _ extra-1;
xs _ cb[ds].uplink;
ENDLOOP;
StoreItems[ds, VDepthOf[ds]+1]; -- in the unlikely case stuff is above
ts _ ds;
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;
stking _ saveStking;
END;

LoadItem: PRIVATE PROC [s: StackIndex] =
BEGIN -- stking is off when called
ds: DataStackIndex = DataIndex[s];
sb: StackBackup = cb[ds].backup;
IF cb[ds].loaded THEN RETURN;
WITH bb: sb SELECT FROM
frame =>
BEGIN
var: VarComponent _ [
wSize: 1, 
space: frame[level: bb.tLevel, wd: bb.tOffset, immutable: TRUE]];
P5L.LoadComponent[var];
END;
link => P5U.Out1[FOpCodes.qLLK, bb.link];
const => P5U.Out1[FOpCodes.qLI, bb.value];
faddr =>
BEGIN
var: VarComponent _ [
wSize: 1, 
space: faddr[level: bb.tLevel, wd: bb.tOffset]];
P5L.LoadComponent[var];
END;
ENDCASE => StkError[];
cb[ds].loaded _ TRUE;
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
ds: DataStackIndex _ DataIndex[s];
sb: StackBackup;
contig: BOOL _ TRUE;
i: CARDINAL _ 0;
off: TempAddr;
lvl: Symbols.ContextLevel;
IF cb[ds].loaded THEN
BEGIN
d: StackPos _ 0;
THROUGH (0..count) DO
ds _ DataIndex[cb[ds].uplink];
IF ~cb[ds].loaded THEN RETURN[[mixed[]]];
ENDLOOP;
s _ ds;
WHILE s # stkPtr DO -- note: this counts marks, used by Load
d _ d+1;
s _ cb[s].uplink;
ENDLOOP;
RETURN[[onStack[d]]];
END;
DO 
sb _ cb[ds].backup;
WITH bb: sb SELECT FROM
frame => 
IF i = 0 THEN {lvl _ bb.tLevel; off _ bb.tOffset}
ELSE {IF bb.tLevel # lvl OR bb.tOffset # off+i THEN contig _ FALSE};
link, const, faddr => 
IF count = 1 THEN RETURN [[contig[sb]]]
ELSE contig _ FALSE;
ENDCASE;
i _ i+1;
IF i = count THEN EXIT;
ds _ DataIndex[cb[ds].uplink];
IF cb[ds].loaded THEN RETURN[[mixed[]]];
ENDLOOP;
IF contig THEN RETURN [[contig[[frame[tOffset: off, tLevel: lvl]]]]]
ELSE RETURN [[stored[]]];
END;

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

MoveToTemp: PUBLIC PROC [
firstIndex: StackIndex, count: CARDINAL, preChaff: CARDINAL]
RETURNS [VarComponent] =
BEGIN -- store "count" words from stack into contiguous temps
<<and pop off preChaff words ahead of firstIndex>>
s: StackIndex;
tStart, tempPrev: TempAddr;
ctlvl: Symbols.ContextLevel = SymbolOps.CtxLevel[CPtr.tempcontext];
lvlPrev: Symbols.ContextLevel;
first: BOOL _ TRUE;
remaining: CARDINAL _ count;
saveStking: BOOL = 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;

stking _ FALSE; -- Stack.Off[];
IF above # StackNull THEN
BEGIN -- unlikely
StoreItems[above, VDepthOf[above]+1];
stkPtr _ cb[above].downlink;
cb[stkPtr].uplink _ StackNull; -- temporarily unlink
END;
IF count = 1 THEN
BEGIN -- trade space for clarity
ds: DataStackIndex = DataIndex[firstIndex];
sb: StackBackup _ cb[ds].backup;
var: VarComponent;
IF cb[ds].loaded THEN {StoreItems[ds, 1]; sb _ cb[ds].backup};
WITH bb: sb SELECT FROM
frame => var _ [wSize: 1, space:
frame[wd: bb.tOffset, immutable: TRUE, level: bb.tLevel]];
link =>
var _ [wSize: 1, space: link[wd: bb.link]];
faddr => var _ [wSize: 1, space:
faddr[wd: bb.tOffset, level: bb.tLevel]];
const =>
var _ [wSize: 1, space: const[d1: bb.value]];
ENDCASE;
DelStackItem[firstIndex];
IF preChaff # 0 THEN Pop[preChaff];
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
ds: DataStackIndex = DataIndex[s];
sb: StackBackup = cb[ds].backup;
WITH bb: sb SELECT FROM
frame => 
BEGIN
IF first THEN
BEGIN
tStart _ bb.tOffset;
lvlPrev _ bb.tLevel;
first _ FALSE;
END
ELSE
BEGIN
IF bb.tLevel # lvlPrev OR bb.tOffset # tempPrev+1 THEN
GO TO moveAll; -- not worth a check for hole after prev
END;
tempPrev _ bb.tOffset;
remaining _ remaining-1;
END;
link, const, faddr, none => 
IF first OR lvlPrev # ctlvl OR tempPrev # CPtr.tempstart-1 THEN GO TO moveAll
ELSE GO TO moveRest;
ENDCASE => StkError[];
ENDLOOP;
EXITS
moveAll =>
BEGIN
remaining _ count;
tStart _ CPtr.tempstart;
lvlPrev _ ctlvl;
GO TO moveRest;
END;
END;
EXITS
moveRest =>
BEGIN
n: CARDINAL _ remaining;
k: CARDINAL;
tlex: Lexeme.se = P5.GenTempLex[remaining];
a: Symbols.BitAddress = seb[tlex.lexsei].idValue;
wa: CARDINAL _ a.wd + remaining - 1;
WHILE n > 0 DO
k _ MIN[n, 2];
Load[Top[k], k];
THROUGH [0..k) DO
wa _ Store[stkPtr, wa, TRUE];
DelStackItem[stkPtr]; -- this updates stkPtr
ENDLOOP;
n _ n - k;
ENDLOOP;
END;
END;

IF remaining < count THEN Pop[count-remaining];
IF preChaff # 0 THEN Pop[preChaff];

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;

Pop: PUBLIC PROC [count: CARDINAL_1] =
BEGIN
saveStking: BOOL = stking;
stking _ FALSE; -- Off[];
THROUGH [0..count) DO
ds: DataStackIndex = DataIndex[stkPtr];
IF cb[ds].loaded THEN P5U.Out0[FOpCodes.qDIS];
DelStackItem[stkPtr];
ENDLOOP;
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
WITH ss: cb[s] SELECT FROM
data => IF ss.loaded THEN extra _ extra + 1;
ENDCASE;
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
<<Store the top element at addr >>
<<if storeNew = FALSE and in memory, then generate POP instead>>
lvl: Symbols.ContextLevel;
ds: DataStackIndex = DataIndex[s];
sb: StackBackup = cb[ds].backup;
IF ~cb[ds].loaded THEN RETURN[addr];
IF storeNew OR sb.where = none THEN
BEGIN
lvl _ SymbolOps.CtxLevel[CPtr.tempcontext];
StoreWord[addr, lvl];
cb[ds].backup _ [frame[tLevel: lvl, tOffset: addr]];
addr _ addr-1;
END
ELSE P5U.Out0[FOpCodes.qDIS];
cb[ds].loaded _ FALSE;
RETURN [addr];
END;

StoreItems: PRIVATE PROC [start: StackIndex, count: CARDINAL] =
BEGIN -- not necessarily contiguously
needed: CARDINAL _ 0;
s, last: DataStackIndex;
ts: StackIndex;
wa: CARDINAL;
ts _ start;
THROUGH [0..count) DO
IF ts = StackNull THEN StkError[];
s _ DataIndex[ts];
IF cb[s].loaded AND cb[s].backup.where = none THEN needed _ needed + 1;
last _ s;
ts _ 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;
ts _ last;
THROUGH [0..count) DO
s _ DataIndex[ts];
IF cb[s].loaded THEN wa _ Store[s, wa, FALSE];
ts _ 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, 0]];
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.

