-- 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];

}.