-- JaMStack.mesa
-- Written by John Warnock, December 1978.
-- Last changed by Doug Wyatt, February 10, 1981 7:10 PM
-- Last changed by Doug Brotz, June 5, 1981 2:38 PM

DIRECTORY
JaMStackDefs,
JaMMasterDefs USING [Frame, Object, Stack, StackEntry, StackLink],
JaMControlDefs USING [GetCurrentFrame, RegisterCommand],
JaMExecDefs USING [JaMError, rangechk, stkovrflw, stkundflw],
JaMFnsDefs USING [PopInteger],
JaMLiteralDefs USING [IntegerLit],
JaMVMDefs USING [AllocateWordsVM, GetWordsVM, PutWordsVM],
Storage USING [FreeWords, Words];

JaMStack: PROGRAM
IMPORTS JaMControlDefs,JaMExecDefs,JaMFnsDefs,JaMLiteralDefs,
vm:JaMVMDefs,Storage
EXPORTS JaMStackDefs =
BEGIN OPEN JaMMasterDefs;

StackAreaPtr: TYPE = POINTER TO StackArea;
StackArea: TYPE = ARRAY [0..stackcount) OF StackEntry;
stackcount: CARDINAL = 256;

stackareaptr: StackAreaPtr ← NIL;
FreeListPtr: StackLink ← NIL;


StkUndFlw: PROCEDURE
= INLINE { OPEN JaMExecDefs; ERROR JaMError[stkundflw,TRUE] };
StkOvrFlw: PROCEDURE
= INLINE { OPEN JaMExecDefs; ERROR JaMError[stkovrflw,FALSE] };
RangeChk: PROCEDURE
= INLINE { OPEN JaMExecDefs; ERROR JaMError[rangechk,TRUE] };

--"Push" pushes a descriptor onto the current operand stack.

Push: PUBLIC PROCEDURE [ob:Object,stack:Stack] =

BEGIN
TempPointer:StackLink;
IF (TempPointer ← FreeListPtr.nextEntry) = NIL THEN

BEGIN
-- A stack overflow, in the JaM machine, is a serious error
-- For this reason all three stacks are packaged into arrays
-- and stored on the operand stack.
obj:Object;
frame: Frame ← JaMControlDefs.GetCurrentFrame[];
ostk:ArrayType Object←MakeStackArray[frame.opstk];
dstk:ArrayType Object←MakeStackArray[frame.dictstk];
estk:ArrayType Object←MakeStackArray[frame.execstk];
Push[ostk, frame.opstk];
Push[dstk, frame.opstk];
Push[estk, frame.opstk];
vm.GetWordsVM[dstk.ArrayPtr,@obj,SIZE[Object]];
Push[obj,frame.dictstk];
StkOvrFlw[];
END;

FreeListPtr↑ ← StackEntry[ob,stack↑];
stack↑ ← FreeListPtr;
FreeListPtr ← TempPointer;
END;

MakeStackArray: PROCEDURE [stack:Stack] RETURNS [ArrayType Object]=

BEGIN
val: Object;
i:CARDINAL ← CountStk[stack];
array: ArrayType Object ←
[lit,ArrayType[i,vm.AllocateWordsVM[i*SIZE[Object]]]];
j: CARDINAL ← array.Length*SIZE[Object];
THROUGH [0..array.Length)
DOj ← j - SIZE[Object];
val ← Pop[stack];
vm.PutWordsVM[array.ArrayPtr + j, @val,SIZE[Object]];
ENDLOOP;
RETURN[array];
END;

CopyStackArray: PROCEDURE [stack:Stack] RETURNS [ArrayType Object]=

BEGIN
k:CARDINAL←0;
i:CARDINAL ← CountStk[stack];
val: Object;
array: ArrayType Object ←
[lit,ArrayType[i,vm.AllocateWordsVM[i*SIZE[Object]]]];
j: CARDINAL ← array.Length*SIZE[Object];
THROUGH [0..array.Length)
DOj ← j - SIZE[Object];
Indx[stack,k];
k←k+1;
val ← Pop[stack];
vm.PutWordsVM[array.ArrayPtr + j, @val,SIZE[Object]];
ENDLOOP;
RETURN[array];
END;

--"Pop" returns the descriptor from the top of the operand stk.

Pop: PUBLIC PROCEDURE [stack:Stack] RETURNS [Ob:Object] =

BEGIN
TempPointer:StackLink;
IF stack↑=NIL THEN StkUndFlw[];
Ob ← stack.ob;
TempPointer ← stack.nextEntry;
stack.nextEntry ← FreeListPtr;
FreeListPtr ← stack↑;
stack↑ ← TempPointer;
END;

--"Top" returns the descriptor from the top of the operand stk without popping.

Top: PUBLIC PROCEDURE [stack:Stack] RETURNS [Ob:Object] =

BEGIN
IF stack↑=NIL THEN StkUndFlw[];
Ob ← stack.ob;
END;

--"Dup" Duplicates the top descriptor onto the stack.

Dup: PUBLIC PROCEDURE [stack:Stack] =

BEGIN
TDesc1:Object ← Top [stack];
Push [TDesc1,stack];
END;

--"Exch" Exchanges the top entries on the stack.

Exch: PUBLIC PROCEDURE [stack:Stack] =

BEGIN
TDesc1:Object ← Pop [stack];
TDesc2:Object ← Pop [stack];
Push [TDesc1,stack]; Push [TDesc2,stack];
END;

-- "ClrStk" moves all entries from the stack to the freelist.

ClrStk: PUBLIC PROCEDURE [stack:Stack] =

BEGIN
tptr0:StackLink;
tptr:StackLink ← stack↑;
IF tptr = NIL THEN RETURN;
UNTIL tptr = NIL

DO
tptr0←tptr;
tptr←tptr.nextEntry;
ENDLOOP;

tptr0.nextEntry←FreeListPtr;
FreeListPtr←stack↑;
stack↑ ← NIL;
END;

-- "CopyStk" copies the top n entries on the given stack.

CopyStk:PUBLIC PROCEDURE [ n:CARDINAL,stack:Stack] =

BEGIN
ob:Object;
tptr:StackLink←NIL;
tstk:Stack←@tptr;
tempptr:StackLink ← stack↑;
IF n = 0 THEN RETURN;
THROUGH [0..n)
DO
IF tempptr = NIL THEN StkUndFlw[];
Push[tempptr.ob,tstk];
tempptr←tempptr.nextEntry;
ENDLOOP;
UNTIL tstk↑ = NIL
DO
ob←Pop[tstk];
Push[ob,stack];
ENDLOOP;
END;

-- "RollStk" rolls the top n entries on the given stack by k places.
-- k>0 is like pop, k<0 is like push

RollStk:PUBLIC PROCEDURE [stack: Stack, n: CARDINAL, k: INTEGER] =

BEGIN
curr: StackLink ← stack↑;
first,kth: StackLink;
kk: CARDINAL;
IF n = 0 THEN RETURN;
k ← k MOD n; --make |k|<n
IF k<0 THEN k ← n+k; --make k positive
IF k = 0 THEN RETURN;
kk ← k;
--Find relevant entries, checking for underflow but making no changes
first ← curr;
THROUGH [1..kk) DO
IF curr=NIL THEN StkUndFlw[];
curr ← curr.nextEntry;
ENDLOOP;
kth ← curr;
THROUGH [kk..n) DO
IF curr=NIL THEN StkUndFlw[];
curr ← curr.nextEntry;
ENDLOOP;
--do it
stack↑ ← kth.nextEntry;
kth.nextEntry ← curr.nextEntry;
curr.nextEntry ← first;
END;

-- "CountStk" counts the entries on the given stack.

CountStk:PUBLIC PROCEDURE [stack:Stack] RETURNS [n:CARDINAL] =

BEGIN
tempptr:StackLink ← stack↑;
n←0;
UNTIL tempptr = NIL
DO
tempptr←tempptr.nextEntry;
n←n+1;
ENDLOOP;
END;

-- "CountToMark" counts the entries on the given stack to the first mark.

CountToMark:PUBLIC PROCEDURE [stack:Stack] RETURNS [n:CARDINAL] =

BEGIN
tempptr:StackLink ← stack↑;
n←0;
UNTIL tempptr = NIL
DO
WITH tempptr.ob SELECT FROM
MarkType => EXIT;
ENDCASE;
tempptr←tempptr.nextEntry;
n←n+1;
ENDLOOP;
END;

ClrToMark:PUBLIC PROCEDURE [stack:Stack]=

BEGIN
ob:Object;
DO
ob←Top[stack];
WITH ob SELECT FROM
MarkType => EXIT;
ENDCASE => []←Pop[stack];
ENDLOOP;
END;

-- "Indx" makes a copy of the ith stack element, counting from 0.

Indx: PUBLIC PROCEDURE [stack:Stack, i: CARDINAL] =

BEGIN
curr: StackLink ← stack↑;
THROUGH [0..i) DO
IF curr=NIL THEN StkUndFlw[];
curr ← curr.nextEntry;
ENDLOOP;
IF curr=NIL THEN StkUndFlw[];
--do it
Push[curr.ob,stack];
END;

-- "MoveStkOps" transfers a number of descriptors from one stack
-- to another. This is an internal procedure.

MoveStkOps: PUBLIC PROCEDURE [ From, To:Stack,Count:CARDINAL] =

BEGIN
TPtr:StackLink;
TPtr2:StackLink;
IF Count <= 0 THEN RETURN;
IF (TPtr ← From↑) = NIL THEN StkUndFlw[];
THROUGH [1..Count) DO
IF (TPtr ← TPtr.nextEntry) = NIL THEN StkUndFlw[];
ENDLOOP;
TPtr2 ← To↑;
To↑← From↑;
From↑← TPtr.nextEntry;
TPtr.nextEntry ← TPtr2;
END;

-- "StackForall" executes a given mesa procedure for each element on the
-- given stack,and returns true if the procedure returns true.

StackForall:PUBLIC PROCEDURE [ stack:Stack,proc:PROCEDURE[obj:Object]
RETURNS [done:BOOLEAN]] RETURNS [BOOLEAN] =

BEGIN
tptr:StackLink;
tptr ← stack↑;
UNTIL tptr = NIL
DO
IF proc[tptr.ob] THEN RETURN [TRUE];
tptr←tptr.nextEntry;
ENDLOOP;
RETURN [FALSE];
END;

-- The next set of routines make the above routines into intrinsics.

PopOpStk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
[]←Pop[frame.opstk];
END;

DupOpStk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
Dup[frame.opstk];
END;

ExchOpStk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
Exch[frame.opstk];
END;

ClearOpStk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
ClrStk[frame.opstk];
END;

CopyOpStk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
i:INTEGER ← JaMFnsDefs.PopInteger[];
IF i < 0 THEN RangeChk[];
CopyStk[i,frame.opstk];
END;

RollOpStk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
k:INTEGER ← JaMFnsDefs.PopInteger[];
n:INTEGER ← JaMFnsDefs.PopInteger[];
IF n < 0 THEN RangeChk[];
RollStk[frame.opstk, n, k];
END;

CountOpStk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
i:INTEGER ← CountStk[frame.opstk];
JaMLiteralDefs.IntegerLit[i,frame.opstk];
END;

CountToMrk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
i:INTEGER ← CountToMark[frame.opstk];
JaMLiteralDefs.IntegerLit[i,frame.opstk];
END;

ClearToMrk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
ClrToMark[frame.opstk];
END;

Mark: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
m:MarkType Object ← [lit,MarkType[]];
Push[m,frame.opstk];
END;

Index: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
i:INTEGER ← JaMFnsDefs.PopInteger[];
IF i < 0 THEN RangeChk[];
Indx[frame.opstk, i];
END;

GetExecStk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
Push[CopyStackArray[frame.execstk],frame.opstk];
END;

GetDictStk: PUBLIC PROCEDURE =

BEGIN
frame:Frame ← JaMControlDefs.GetCurrentFrame[];
Push[CopyStackArray[frame.dictstk],frame.opstk];
END;

--The next two procedures are used in conjunction with error recovery.

FreeLoc: PUBLIC PROCEDURE RETURNS [sl:StackLink]=
BEGIN
RETURN[FreeListPtr];
END;

RestoreStk: PUBLIC PROCEDURE [sl:StackLink,s:Stack]=
BEGIN
tmp:StackLink;
UNTIL sl = FreeListPtr
DO
IF FreeListPtr = NIL THEN RETURN;
tmp ←FreeListPtr;
FreeListPtr ← FreeListPtr.nextEntry;
tmp.nextEntry ← s↑;
s↑ ← tmp;
ENDLOOP;
END;

CleanupStack: PUBLIC PROCEDURE =
{IF stackareaptr # NIL THEN
{Storage.FreeWords[stackareaptr]; stackareaptr ← NIL}};

-- Initialization

stackareaptr ← Storage.Words[SIZE[StackArea]];

FOR i: CARDINAL IN [0..stackcount-1) DO
stackareaptr[i].nextEntry ← @stackareaptr[i+1];
ENDLOOP;
stackareaptr[stackcount-1].nextEntry ← NIL;
FreeListPtr ← @stackareaptr[0];

STOP;

{ OPEN JaMControlDefs;
--Stack commands
RegisterCommand[".pop"L,PopOpStk];
RegisterCommand[".exch"L,ExchOpStk];
RegisterCommand[".dup"L,DupOpStk];
RegisterCommand[".clrstk"L,ClearOpStk];
RegisterCommand[".copy"L,CopyOpStk];
RegisterCommand[".roll"L,RollOpStk];
RegisterCommand[".cntstk"L,CountOpStk];
RegisterCommand[".cnttomrk"L,CountToMrk];
RegisterCommand[".clrtomrk"L,ClearToMrk];
RegisterCommand[".execstk"L,GetExecStk];
RegisterCommand[".dictstk"L,GetDictStk];
RegisterCommand[".mark"L,Mark];
RegisterCommand[".index"L,Index];
};

END.

DKW March 28, 1980 3:34 PM
added StartStack
DKW April 1, 1980 3:52 PM
now uses NotifyCommand, NotifyStringObject
DKW September 30, 1980 5:40 PM
added Indx, Index
DKW December 4, 1980 1:46 PM
added .execstk, .dictstk commands
uses Storage.Words instead of SystemDefs.AllocateResidentPages
DKW February 10, 1981 6:25 PM
imports errors from JaMExecDefs; initializes after STOP
DKB June 5, 1981 2:37 PM
export CleanupStack.