crc/retroforth
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add a FIFO queue to the examples

Browse source 
FossilOrigin-Name: 5d5f3ef6bc2005fada05735decf9cd6989d9c8d487f7cd786e2196533977ebd6
This commit is contained in:
crc 2019-12-26 20:28:59 +00:00
parent 28260d7709
commit 77f4ca143d
1 changed files with 46 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

46
example/queue.retro Normal file
View file

@ -0,0 +1,46 @@
This implements a FIFO queue. It's directly based on the code in
a comp.lang.forth post titled "A queue without move". See
https://narkive.com/khcCauFY for the original posting.
~~~
:q:named (size,string) d:create #0 , #0 , dup , allot ;
:q:head (q-a) ; immediate
:q:tail (q-a) n:inc ;
:q:size (q-n) #2 + fetch ;
:q:list (q-a) #3 + ;
:q:mask (q-n) q:size n:dec ;
:q:len (q-n) [ q:head fetch ] [ q:tail fetch ] bi - ;
:q:free (q-n) [ q:size ] sip q:len - ;
:q:clear (q-) [ q:head v:off ] [ q:tail v:off ] bi ;
:q:masked (aq-n) q:mask swap fetch and ;
:q:reset0 (q-) dup q:len n:zero? [ q:clear ] [ drop ] choose ;
{{
'R var
:head? @R q:tail @R q:masked eq? ;
:tail? @R q:head fetch n:dec @R q:mask and eq? ;
:display nl I dup n:put sp dup @R q:list + fetch n:put sp ;
---reveal---
:q:add (nq-f)
[ !R ] [ q:free n:strictly-positive? ] bi
[ @R q:list @R q:head @R q:masked + store
@R q:head v:inc TRUE ]
[ drop FALSE ] choose ;
:q:get (q-nf)
[ !R ] [ q:len n:strictly-positive? ] bi
[ @R q:list @R q:tail @R q:masked + fetch @R q:tail
v:inc TRUE @R q:reset0 ]
[ #0 FALSE ] choose ;
:q:put (q-)
[ !R ] [ q:free ] [ q:len ] tri
'\nin_que:_%n,_free:_%n s:format s:put
@R q:len n:strictly-positive?
[ @R q:size
[ display dup head? [ '<--_tail s:put ] if
tail? [ '<--_head s:put ] if
] times<with-index> ]
[ 'queue_is_empty s:put nl ] choose ;
}}
~~~