mirror of
https://git.sr.ht/~crc_/retroforth
synced 2024-11-16 19:48:56 +01:00
155 lines
3.5 KiB
Text
155 lines
3.5 KiB
Text
# FIFO Queue
|
|
|
|
This implements a FIFO queue. It was based on the code in
|
|
a comp.lang.forth post titled "A queue without move", but
|
|
has been refactored and expanded slightly. See
|
|
https://narkive.com/khcCauFY for the original posting.
|
|
|
|
# Limits
|
|
|
|
The queue size needs to be a power of 2.
|
|
|
|
# Code
|
|
|
|
~~~
|
|
:q:new (n-a) here [ #0 , #0 , dup , allot ] dip ;
|
|
:q:named (ns-) [ q:new ] dip const ;
|
|
: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:length (q-n) [ q:head fetch ] [ q:tail fetch ] bi - ;
|
|
:q:free (q-n) &q:size sip q:length - ;
|
|
:q:clear (q-) [ q:head v:off ] [ q:tail v:off ] bi ;
|
|
:q:masked (aq-n) q:mask swap fetch and ;
|
|
:q:empty? (q-f) q:length n:zero? ;
|
|
:q:full? (q-f) &q:length &q:size bi eq? ;
|
|
:q:reset0 (q-) dup q:empty? &q:clear &drop choose ;
|
|
|
|
{{
|
|
'R var
|
|
|
|
(for_adding_values)
|
|
:append-value swap @R q:list @R q:head @R q:masked + store
|
|
@R q:head v:inc ;
|
|
|
|
(for_fetching_values)
|
|
:peek-value @R q:list @R q:tail @R q:masked + fetch ;
|
|
:fetch-value peek-value @R q:tail v:inc swap @R q:reset0 ;
|
|
---reveal---
|
|
:q:add (nq-f)
|
|
[ !R ] [ q:free n:strictly-positive? dup ] bi
|
|
[ append-value ] if; nip ;
|
|
|
|
:q:get (q-nf)
|
|
[ !R ] [ q:length n:strictly-positive? dup ] bi
|
|
[ fetch-value ] if; #0 swap ;
|
|
|
|
:q:peek (q-nf)
|
|
[ !R ] [ q:length n:strictly-positive? dup ] bi
|
|
[ peek-value swap ] if; #0 swap ;
|
|
}}
|
|
~~~
|
|
|
|
I am separating out the display code as it's fairly large
|
|
and some may want to leave it out. (When compiled, this
|
|
increases the size by more than 50%. While useful, the size
|
|
hit may make it undesirable on systems with tight memory
|
|
constraints)
|
|
|
|
~~~
|
|
{{
|
|
'R var
|
|
|
|
(for_display)
|
|
: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 ;
|
|
:indicators dup head? [ '<--_tail s:put ] if
|
|
tail? [ '<--_head s:put ] if ;
|
|
---reveal---
|
|
:q:put (q-)
|
|
[ !R ] [ q:free ] [ q:length ] tri
|
|
'\nin_que:_%n,_free:_%n s:format s:put
|
|
@R q:length n:strictly-positive?
|
|
[ @R q:size [ display indicators ] times<with-index> ]
|
|
[ 'queue_is_empty s:put nl ] choose ;
|
|
}}
|
|
~~~
|
|
|
|
# Usage
|
|
|
|
The original didn't include any documentation, so here are a few
|
|
brief notes on this.
|
|
|
|
Creating a new queue:
|
|
|
|
q:new
|
|
q:named
|
|
|
|
Examples:
|
|
|
|
#16 q:new (returns_a_pointer_to_the_queue)
|
|
#16 'Q q:named (create_a_queue_and_create_a_constant)
|
|
(pointing_to_it)
|
|
|
|
See the Limits section for a note on the sizing.
|
|
|
|
Adding Values:
|
|
|
|
#1 Q q:add
|
|
#2 Q q:add
|
|
|
|
The `q:add` returns a flag indicating success or fail. Check or
|
|
discard this as necessary for your application.
|
|
|
|
Retreive Values:
|
|
|
|
Q q:get
|
|
Q q:get
|
|
|
|
Like `q:add`, this returns a flag indicating success or failure.
|
|
This also returns the value, or a value of 0 on failure.
|
|
|
|
Empty the Queue:
|
|
|
|
Q q:clear
|
|
|
|
Queue Queries:
|
|
|
|
Q q:size
|
|
Q q:length
|
|
|
|
# A Test
|
|
|
|
```
|
|
#16 'Q q:named
|
|
Q q:empty? n:put nl
|
|
#100 Q q:add drop
|
|
Q q:empty? n:put nl
|
|
Q q:get drop-pair
|
|
Q q:empty? n:put nl nl
|
|
|
|
Q q:full? n:put nl
|
|
#16 [ #100 Q q:add drop ] times
|
|
Q q:full? n:put nl
|
|
Q q:size [ Q q:get drop-pair ] times
|
|
Q q:full? n:put nl nl
|
|
|
|
#100 Q q:add
|
|
#200 Q q:add
|
|
#300 Q q:add
|
|
#400 Q q:add
|
|
#500 Q q:add dump-stack nl reset
|
|
Q q:put
|
|
nl 'values:_ s:put
|
|
Q q:get drop n:put sp
|
|
Q q:get drop n:put sp
|
|
Q q:peek drop n:put sp
|
|
Q q:peek drop n:put sp
|
|
Q q:peek drop n:put sp
|
|
Q q:get drop n:put sp
|
|
Q q:get drop n:put nl nl
|
|
Q q:put
|
|
```
|