aboutsummaryrefslogtreecommitdiff
path: root/amforth-6.5/examples/stack.frt
blob: b640cfb9eecfa8fd1c78a6b181d51c5298c6239b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
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
;