aboutsummaryrefslogtreecommitdiff
path: root/amforth-6.5/examples/stack.frt
diff options
context:
space:
mode:
Diffstat (limited to 'amforth-6.5/examples/stack.frt')
-rw-r--r--amforth-6.5/examples/stack.frt76
1 files changed, 76 insertions, 0 deletions
diff --git a/amforth-6.5/examples/stack.frt b/amforth-6.5/examples/stack.frt
new file mode 100644
index 0000000..b640cfb
--- /dev/null
+++ b/amforth-6.5/examples/stack.frt
@@ -0,0 +1,76 @@
+\
+\ separate stacks for cell sized data
+\
+\ Date: Nov 13, 2016
+\ Author: Matthias Trute
+
+\ allocate a stack region with at most
+\ size elements
+: stack ( size -- stack-id )
+ 1+ ( size ) cells here swap allot
+ 0 over ! \ empty stack
+;
+
+\ replace the stack content with data from
+\ the data stack.
+: set-stack ( rec-n .. rec-1 n recstack-id -- )
+ over 0< if -4 throw then \ stack underflow
+ 2dup ! cell+ swap cells bounds
+ ?do i ! 1 cells +loop
+;
+
+\ read the whole stack to the data stack
+: get-stack ( recstack-id -- rec-n .. rec-1 n )
+ dup @ >r r@ cells + r@ begin
+ ?dup
+ while
+ 1- over ( -- a n a )
+ @ ( -- a n r_i)
+ rot 1 cells -
+ rot ( -- r_i a n )
+ repeat
+ drop r>
+;
+
+\ execute XT for earch element of the stack
+\ leave the loop if the XT returns TRUE
+: map-stack ( i*x XT stack-id -- j*y f )
+ dup cell+ swap @ cells bounds ?do
+ ( -- i*x XT )
+ i @ swap dup >r execute
+ ?dup if r> drop unloop exit then
+ r> 1 cells +loop
+ drop 0
+;
+
+\ add an item as new top of the stack
+: >stack ( x stack-id -- )
+ 2dup 2>r nip get-stack 2r> rot 1+ swap set-stack
+;
+
+\ destructivly get Top Of Stack
+: stack> ( stack-id -- x )
+ dup >r get-stack 1- r> rot >r set-stack r>
+;
+
+\ actual stack depth
+: depth-stack ( stack-id -- n )
+ @
+;
+
+\ copy a stack item
+: pick-stack ( n stack-id -- n' )
+ 2dup depth-stack 0 swap within 0= if -9 throw then
+ cell+ swap cells + @
+;
+
+\ add an item at the bottom of a stack
+: >back ( x stack-id -- )
+ dup >r get-stack 1+ r> set-stack
+;
+
+\ destructivly get Bottom Of Stack
+: back> ( stack-id -- x )
+ dup >r get-stack 1- r> set-stack
+;
+