From 67d25d837ac55f28a366c0a3b262e439a6e75fc3 Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Sat, 19 Aug 2017 12:15:28 +0200 Subject: Add AmForth --- amforth-6.5/examples/stack.frt | 76 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 amforth-6.5/examples/stack.frt (limited to 'amforth-6.5/examples/stack.frt') 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 +; + -- cgit v1.2.3