-- JaMStackImpl.mesa
-- Original version by John Warnock, December 1978.
-- Last changed by Bill Paxton, January 21, 1:09 PM
-- Last changed by Doug Wyatt,  7-Oct-81 11:07:22

DIRECTORY
  JaMBasic USING [Object],
  JaMInternal USING [Frame, Node, NodeSequence, Stack, StackRecord],
  JaMOps USING [APut, Array, Error, Install, InstallReason, MakeName, nullOb,
    Overflow, Pop, PopCardinal, PopInteger, Push, PushCardinal, rangechk,
    RegisterExplicit, StackOverflow, Top, Underflow],
  JaMStorage USING [Zone],
  Inline USING [LowHalf];

JaMStackImpl: MONITOR
IMPORTS JaMOps, JaMStorage, Inline
EXPORTS JaMOps = {
OPEN JaMOps, JaMInternal, JaMBasic;

-- Globals

zone: UNCOUNTED ZONE = JaMStorage.Zone[];

stkundflw,stkovrflw: name Object;

-- Error handling

Underflow: PUBLIC PROC[stack: Stack] = { ERROR Error[stkundflw] };

Overflow: PUBLIC PROC[stack: Stack] = { ERROR StackOverflow[stack] };

Restore: PUBLIC PROC[stack: Stack, mark: Node] = {
  -- try to restore the stack so that mark is the head of the free list
  -- first, be sure the marked node is in the free list
  FOR node: Node ← stack.free, node.next UNTIL node=NIL DO
    IF node=mark THEN EXIT;
    REPEAT FINISHED => RETURN; -- not found
    ENDLOOP;
  -- move nodes from the free list back onto the stack
  UNTIL stack.free=mark DO
    node: Node ← stack.free; stack.free ← node.next;
    node.next ← stack.head; stack.head ← node;
    ENDLOOP;
  };

-- Stack allocation

NewStack: PUBLIC PROC[n: CARDINAL] RETURNS[Stack] = {
  nodes: LONG POINTER TO NodeSequence ← zone.NEW[NodeSequence[n]];
  stack: Stack ← zone.NEW[StackRecord ← [head: NIL, free: NIL, nodes: nodes]];
  FOR i: CARDINAL IN[0..n) DO
    node: Node ← @nodes[i];
    node↑ ← [next: stack.free, ob: nullOb];
    stack.free ← node;
    ENDLOOP;
  RETURN[stack];
  };

FreeStack: PUBLIC PROC[stack: Stack] = {
  zone.FREE[@stack.nodes];
  zone.FREE[@stack];
  };

-- Stack operations

Dup: PUBLIC PROC[stack: Stack] = {
  ob: Object ← Top[stack]; Push[stack,ob] };

Exch: PUBLIC PROC[stack: Stack] = {
  ob1: Object ← Pop[stack]; ob2: Object ← Pop[stack];
  Push[stack,ob1]; Push[stack,ob2] };

-- Returns MIN[<nodes in list>,max]
Count: PROC[head: Node, max: CARDINAL ← LAST[CARDINAL]]
  RETURNS[CARDINAL] = INLINE {
  FOR i: CARDINAL IN[0..max) DO
    IF head=NIL THEN RETURN[i] ELSE head ← head.next;
    ENDLOOP;
  RETURN[max] };

-- Copy the top n entries
Copy: PUBLIC PROC[stack: Stack, n: CARDINAL] = {
  head: Node ← NIL; -- will be new head of stack
  last: LONG POINTER TO Node ← @head; -- last link field
  temp: Node ← stack.head;
  IF n=0 THEN RETURN;
  IF Count[stack.head,n]<n THEN Underflow[stack]; -- need n nodes to copy
  IF Count[stack.free,n]<n THEN Overflow[stack]; -- intend to create n nodes
  -- Now do it
  THROUGH [0..n) DO
    node: Node ← stack.free; stack.free ← node.next;
    last↑ ← node; last ← @node.next;
    node.ob ← temp.ob; temp ← temp.next;
    ENDLOOP;
  last↑ ← stack.head; stack.head ← head;
  };

-- Roll the top n entries by k places (in the "Pop" direction)
Roll: PUBLIC PROC[stack: Stack, n,k: CARDINAL] = {
  top,kth,nth: Node;
  IF n=0 OR (k ← k MOD n)=0 THEN RETURN;
  top ← stack.head; IF top=NIL THEN Underflow[stack];
  kth ← top; THROUGH[1..k) DO kth ← kth.next;
    IF kth=NIL THEN Underflow[stack] ENDLOOP;
  nth ← kth; THROUGH[k..n) DO nth ← nth.next;
    IF nth=NIL THEN Underflow[stack] ENDLOOP;
  stack.head ← kth.next; kth.next ← nth.next; nth.next ← top;
  };

CountStack: PUBLIC PROC[stack: Stack, max: CARDINAL ← LAST[CARDINAL]]
  RETURNS[CARDINAL] = { RETURN[Count[stack.head,max]] };

ClearStack: PUBLIC PROC[stack: Stack] = {
  UNTIL stack.head=NIL DO
    node: Node ← stack.head; stack.head ← node.next;
    node.next ← stack.free; stack.free ← node;
    ENDLOOP;
  };

CountToMark: PUBLIC PROC[stack: Stack] RETURNS[CARDINAL] = {
  n: CARDINAL ← 0;
  FOR node: Node ← stack.head, node.next UNTIL node=NIL DO
    IF node.ob.type = mark THEN EXIT ELSE n ← n + 1;
    ENDLOOP;
  RETURN[n];
  };

ClearToMark: PUBLIC PROC[stack: Stack] = {
  UNTIL stack.head=NIL DO
    IF Pop[stack].type=mark THEN EXIT;
    ENDLOOP;
  };

-- Return the ith stack element, counting from 0.
Index: PUBLIC PROC[stack: Stack, i: CARDINAL] RETURNS[Object] = {
  ith: Node ← stack.head;
  THROUGH [0..i) UNTIL ith=NIL DO ith ← ith.next ENDLOOP;
  IF ith=NIL THEN Underflow[stack];
  RETURN[ith.ob];
  };

-- Execute the given procedure for each element on the given stack
-- Stop the enumeration and return TRUE if the procedure returns TRUE.
StackForAll: PUBLIC PROC[stack: Stack, proc: PROC[Object] RETURNS[BOOLEAN],
  unwind: BOOLEAN] RETURNS[BOOLEAN] = {
  node: Node ← stack.head;
  UNTIL node=NIL DO
    IF proc[node.ob] THEN RETURN[TRUE];
    IF unwind THEN { [] ← Pop[stack]; node ← stack.head }
    ELSE node ← node.next;
    ENDLOOP;
  RETURN[FALSE];
  };

ArrayFromStack: PUBLIC PROC[stack: Stack] RETURNS[array Object] = {
  size: CARDINAL ← Count[stack.head]; 
  array: array Object ← Array[size];
  node: Node ← stack.head;
  FOR i: CARDINAL IN[0..size) DO
    APut[array,i,node.ob]; node ← node.next;
    ENDLOOP;
  RETURN[array];
  };

-- Stack intrinsics

JPop: PUBLIC PROC[frame: Frame] = {
  [] ← Pop[frame.opstk];
  };

JDup: PUBLIC PROC[frame: Frame] = {
  Dup[frame.opstk];
  };

JExch: PUBLIC PROC[frame: Frame] = {
  Exch[frame.opstk];
  };

JCopy: PUBLIC PROC[frame: Frame] = {
  i: CARDINAL ← PopCardinal[frame.opstk];
  Copy[frame.opstk,i];
  };

JRoll: PUBLIC PROC[frame: Frame] = {
  kk: LONG INTEGER ← PopInteger[frame.opstk];
  nn: LONG INTEGER ← PopInteger[frame.opstk];
  k,n: INTEGER;
  nmax: INTEGER = LAST[INTEGER];
  IF nn<0 THEN ERROR Error[rangechk];
  n ← Inline.LowHalf[MIN[nn,nmax]]; -- expect .stkundflw IF n=nmax
  k ← IF n=0 THEN 0 ELSE Inline.LowHalf[kk MOD n];
  IF k<0 THEN k ← k + n; Roll[frame.opstk,n,k];
  };

JClrStk: PUBLIC PROC[frame: Frame] = {
  ClearStack[frame.opstk];
  };

JCntStk: PUBLIC PROC[frame: Frame] = {
  n: CARDINAL ← CountStack[frame.opstk];
  PushCardinal[frame.opstk,n];
  };

JCntToMrk: PUBLIC PROC[frame: Frame] = {
  n: CARDINAL ← CountToMark[frame.opstk];
  PushCardinal[frame.opstk,n];
  };

JClrToMrk: PUBLIC PROC[frame: Frame] = {
  ClearToMark[frame.opstk];
  };

JMark: PUBLIC PROC[frame: Frame] = {
  Push[frame.opstk,[L,mark[]]];
  };

JIndex: PUBLIC PROC[frame: Frame] = {
  i: CARDINAL ← PopCardinal[frame.opstk];
  ob: Object ← Index[frame.opstk, i];
  Push[frame.opstk,ob];
  };

JExecStk: PUBLIC PROC[frame: Frame] = {
  array: array Object ← ArrayFromStack[frame.execstk];
  Push[frame.opstk, array];
  };

JDictStk: PUBLIC PROC[frame: Frame] = {
  array: array Object ← ArrayFromStack[frame.dictstk];
  Push[frame.opstk, array];
  };

-- Initialization

InstallStack: PROC[why: InstallReason, frame: Frame] = { SELECT why FROM
  register => {
    stkundflw ← MakeName[".stkundflw"L];
    stkovrflw ← MakeName[".stkovrflw"L];
    RegisterExplicit[frame, ".pop"L, JPop];
    RegisterExplicit[frame, ".exch"L, JExch];
    RegisterExplicit[frame, ".dup"L, JDup];
    RegisterExplicit[frame, ".clrstk"L, JClrStk];
    RegisterExplicit[frame, ".copy"L, JCopy];
    RegisterExplicit[frame, ".roll"L, JRoll];
    RegisterExplicit[frame, ".cntstk"L, JCntStk];
    RegisterExplicit[frame, ".cnttomrk"L, JCntToMrk];
    RegisterExplicit[frame, ".clrtomrk"L, JClrToMrk];
    RegisterExplicit[frame, ".mark"L, JMark];
    RegisterExplicit[frame, ".index"L, JIndex];
    RegisterExplicit[frame, ".execstk"L, JExecStk];
    RegisterExplicit[frame, ".dictstk"L, JDictStk];
    };
    ENDCASE;
  };

Install[InstallStack];

}.