<> <> <> <> <> DIRECTORY Basics USING [LowHalf], 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]; JaMStackImpl: MONITOR IMPORTS JaMOps, JaMStorage, Basics EXPORTS JaMOps = { OPEN JaMOps, JaMInternal, JaMBasic; <> zone: UNCOUNTED ZONE = JaMStorage.Zone[]; stkundflw,stkovrflw: name Object; <> Underflow: PUBLIC PROC[stack: Stack] = { ERROR Error[stkundflw] }; Overflow: PUBLIC PROC[stack: Stack] = { ERROR StackOverflow[stack] }; Restore: PUBLIC PROC[stack: Stack, mark: Node] = { <> <> FOR node: Node _ stack.free, node.next UNTIL node=NIL DO IF node=mark THEN EXIT; REPEAT FINISHED => RETURN; -- not found ENDLOOP; <> UNTIL stack.free=mark DO node: Node _ stack.free; stack.free _ node.next; node.next _ stack.head; stack.head _ node; ENDLOOP; }; <> 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]; }; <> 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] }; <,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: 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]> 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: 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; }; <> 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]; }; <> <> 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]; }; <> 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 _ Basics.LowHalf[MIN[nn,nmax]]; -- expect .stkundflw IF n=nmax k _ IF n=0 THEN 0 ELSE Basics.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]; }; <> 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]; }.