-- 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];(600)

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] =\1b8B654b4B
BEGIN
TempPointer:StackLink;
IF (TempPointer _ FreeListPtr.nextEntry) = NIL THENl4268
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;l5538
FreeListPtr^ _ StackEntry[ob,stack^];
stack^ _ FreeListPtr;
FreeListPtr _ TempPointer;
END;l4268

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)
DO	j _ j - SIZE[Object];
	val _ Pop[stack];
	vm.PutWordsVM[array.ArrayPtr + j, @val,SIZE[Object]];
ENDLOOP;
RETURN[array];
END;l4268

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)
DO	j _ j - SIZE[Object];
	Indx[stack,k];
	k_k+1;
	val _ Pop[stack];
	vm.PutWordsVM[array.ArrayPtr + j, @val,SIZE[Object]];
ENDLOOP;
RETURN[array];
END;l4268

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

Pop: PUBLIC PROCEDURE [stack:Stack] RETURNS [Ob:Object] =\66b3B
BEGIN
TempPointer:StackLink;
IF stack^=NIL THEN StkUndFlw[];
Ob _ stack.ob;
TempPointer _ stack.nextEntry;
stack.nextEntry _ FreeListPtr;
FreeListPtr _ stack^;
stack^ _ TempPointer;
END;l4268


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

Top: PUBLIC PROCEDURE [stack:Stack] RETURNS [Ob:Object] =\83b3B
BEGIN
IF stack^=NIL THEN StkUndFlw[];
Ob _ stack.ob;
END;l4268

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

Dup: PUBLIC PROCEDURE [stack:Stack] =\56b3B
BEGIN
TDesc1:Object _ Top [stack];
Push [TDesc1,stack];
END;l4268

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

Exch: PUBLIC PROCEDURE [stack:Stack] =\51b4B
BEGIN
TDesc1:Object _ Pop [stack];
TDesc2:Object _ Pop [stack];
Push [TDesc1,stack]; Push [TDesc2,stack];
END;l4268

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

ClrStk: PUBLIC PROCEDURE [stack:Stack] =\64b6B
BEGIN
tptr0:StackLink;
tptr:StackLink _ stack^;
IF tptr = NIL THEN RETURN;
UNTIL tptr = NILl4268
DO
tptr0_tptr;
tptr_tptr.nextEntry;
ENDLOOP;l5538
tptr0.nextEntry_FreeListPtr;
FreeListPtr_stack^;
stack^ _ NIL;
END;l4268

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

CopyStk:PUBLIC PROCEDURE [ n:CARDINAL,stack:Stack] =\b1B58b8B
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;l4268

-- "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] =\b1B106b8B
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;l4268


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

CountStk:PUBLIC PROCEDURE [stack:Stack] RETURNS [n:CARDINAL] =\55b9B
BEGIN
tempptr:StackLink _ stack^;
n_0;
UNTIL tempptr = NIL
DO 
tempptr_tempptr.nextEntry;
n_n+1;
ENDLOOP;
END;l4268

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

CountToMark:PUBLIC PROCEDURE [stack:Stack] RETURNS [n:CARDINAL] =\75b12B
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;l4268

ClrToMark:PUBLIC PROCEDURE [stack:Stack]=\b10B
BEGIN
ob:Object;
DO 
ob_Top[stack];
WITH ob SELECT FROM
MarkType => EXIT;
ENDCASE  => []_Pop[stack];
ENDLOOP;
END;l4268

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

Indx: PUBLIC PROCEDURE [stack:Stack, i: CARDINAL] =(1792)\67b5B
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;l4268

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

MoveStkOps: PUBLIC PROCEDURE [ From, To:Stack,Count:CARDINAL] =(600)\113b10B
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;l4268

-- "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] =\138b11B
BEGIN
tptr:StackLink;
tptr _ stack^;
UNTIL tptr = NIL
DO 
IF proc[tptr.ob] THEN RETURN [TRUE];
tptr_tptr.nextEntry;
ENDLOOP;
RETURN [FALSE];
END;l4268



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

PopOpStk: PUBLIC PROCEDURE  =\73b8B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
[]_Pop[frame.opstk];
END;l4268

DupOpStk: PUBLIC PROCEDURE  =\1b8B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
Dup[frame.opstk];
END;l4268

ExchOpStk: PUBLIC PROCEDURE =\1b9B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
Exch[frame.opstk];
END;l4268

ClearOpStk: PUBLIC PROCEDURE =\1b10B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
ClrStk[frame.opstk];
END;l4268

CopyOpStk: PUBLIC PROCEDURE =\b10B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
i:INTEGER _ JaMFnsDefs.PopInteger[];
IF i < 0  THEN RangeChk[];
CopyStk[i,frame.opstk];
END;l4268

RollOpStk: PUBLIC PROCEDURE =\b10B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
k:INTEGER _ JaMFnsDefs.PopInteger[];
n:INTEGER _ JaMFnsDefs.PopInteger[];
IF n < 0 THEN RangeChk[];
RollStk[frame.opstk, n, k];
END;l4268

CountOpStk: PUBLIC PROCEDURE =\b11B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
i:INTEGER _ CountStk[frame.opstk];
JaMLiteralDefs.IntegerLit[i,frame.opstk];
END;l4268

CountToMrk: PUBLIC PROCEDURE =\b11B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
i:INTEGER _ CountToMark[frame.opstk];
JaMLiteralDefs.IntegerLit[i,frame.opstk];
END;l4268

ClearToMrk: PUBLIC PROCEDURE =\b11B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
ClrToMark[frame.opstk];
END;l4268

Mark: PUBLIC PROCEDURE =\b5B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
m:MarkType Object _ [lit,MarkType[]];
Push[m,frame.opstk];
END;l4268

Index: PUBLIC PROCEDURE =(1792)\b6B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
i:INTEGER _ JaMFnsDefs.PopInteger[];
IF i < 0 THEN RangeChk[];
Indx[frame.opstk, i];
END;l4268

GetExecStk: PUBLIC PROCEDURE =\b11B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
Push[CopyStackArray[frame.execstk],frame.opstk];
END;l4268

GetDictStk: PUBLIC PROCEDURE =\b11B
BEGIN
frame:Frame _ JaMControlDefs.GetCurrentFrame[];
Push[CopyStackArray[frame.dictstk],frame.opstk];
END;l4268

--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.
(600)\b1B72b7B79b10B