Singly Linked List implementation in forth using gforth's structs.

sllist.fs

\ sllist.fs - Singly Linked List implementation in forth using gforth's structs.

\G A node contains the address of the next node and the address of a
\G counted string.
struct
    cell% field node-text               \ address of counted string
    cell% field node-next               \ address of next node
end-struct node%

\G Initialize a node given the address of a counted string and the
\G address of the next node, for building lists manually.
: node-init ( text-addr next-node-addr node-addr -- )
    tuck ( text-addr node-addr next-node-addr node-addr )
    node-next ! ( text-addr node-addr )
    node-text !
;

\G Given the address of a node display its text on the screen.
: node-type ( node-addr -- )   node-text @ count type ;

\G Given the address of an cell pointing to the first node in a
\G list, step down the list of nodes and display the text of each node
\G to the screen.
: node-traverse ( first-addr -- )
    begin
        dup @ 0<>
    while
        cr dup @ node-type
        @ node-next
    repeat
    drop
;

\G Given the addresses of two nodes compare their texts in the manner
\G of COMPARE, so node1 text < node2 text leaves -1, node1 text =
\G node2 text leaves 0, and node1 text > node2 text leaves 1.
: node-text-compare ( node1-addr node2-addr -- flag )
    node-text @ count rot node-text @ count 2swap compare
;

\G Given the address of a new node and the address of a pointer to a
\G list of nodesd insert the new node in order its node-text.
: node-insert ( new-node-addr p-addr )
    dup @ 0= if ( new-node-addr p-addr )
        \ p-addr @ is null, so the new node is first element in the list,
        \ so just save its address in p.
        !
        exit
    then

    2dup @ node-text-compare -1 = if
        \ The new node text is < the first node text, so save it as the first
        \ node.
        2dup @ ( new-node-addr p-addr new-node-addr first-node-addr )
        swap node-next ! \ Save the first node in node-next of the new node.
        !                \ Save the new node in the list header.
        exit
    then

    ( new-node-addr p-addr )  \ When we get here we know p is not null
    begin
        dup @ node-next @ 0<>           \ Is next entry null?
    while ( new-node-addr p-addr )
        2dup @ node-text-compare 1 = \ Is the next's node-text > the new nodes'?
    while ( new-node-addr p-addr )
        @ node-next                     \ move to the next node.
    repeat then

    \ When we get here we want to add the new node *after* the old node.
    ( new-node-addr p-addr )
    2dup ( new-node-addr p-addr new-node-addr p-addr )
    @ node-next @ ( new-node-addr p-addr new-node-addr old-node.next )
    swap  ( new-node-addr p-addr old-node new-node-addr )

    \ Store address of old node in new node's node-next slot.
    node-next ! ( new-node-addr p-addr )

    \ Store address of new node in next-node slot of node pointed to by p.
    @ node-next !
;

: node-insert-uncommented ( new-node-addr p-addr )
    dup @ 0= if ! exit then
    2dup @ node-text-compare -1 = if 2dup @   swap node-next !   !   exit then
    begin
        dup @ node-next @ 0<>
    while
        2dup @ node-text-compare 1 =
    while
        @ node-next
    repeat then
    2dup   @ node-next @  swap
    node-next !
    @ node-next !
;

\ Build the initial list manually.
\ Create some strings.
create s1 ," a"
create s2 ," m"
create s3 ," x"

\ Create some nodes and initialize them, making links between them.
node% %allot constant n3   s3  0 n3 node-init
node% %allot constant n2   s2 n3 n2 node-init
node% %allot constant n1   s1 n2 n1 node-init

variable l1  n1 l1 !              \ original list

\ Create some other nodes for later use with the l2 list.
create s4 ," o"
create s5 ," x"
create s6 ," h"
create s7 ," a"
create s8 ," m"
create s9 ," z"

node% %allot constant n4    s4  0 n4  node-init
node% %allot constant n5    s5  0 n5  node-init
node% %allot constant n6    s6  0 n6  node-init
node% %allot constant n7    s7  0 n7  node-init
node% %allot constant n8    s8  0 n8  node-init
node% %allot constant n9    s9  0 n9  node-init
node% %allot constant n10   s8  0 n10 node-init
node% %allot constant n11   s7  0 n11 node-init
node% %allot constant n12   s9  0 n12 node-init

variable l2   0 l2 !                  \ the other list

\ Use hex when debugging, because you'll be looking at long 8 byte addresses.
hex


\ Words for debugging
: type-data ( -- )
    cr ." l2: " l2 .
    cr ." n4 : " n4  . n4  node-type  space n4  node-next @ .
    cr ." n5 : " n5  . n5  node-type  space n5  node-next @ .
    cr ." n6 : " n6  . n6  node-type  space n6  node-next @ .
    cr ." n7 : " n7  . n7  node-type  space n7  node-next @ .
    cr ." n8 : " n8  . n8  node-type  space n8  node-next @ .
    cr ." n9 : " n9  . n9  node-type  space n9  node-next @ .
    cr ." n10: " n10 . n10 node-type  space n10 node-next @ .
    cr ." n11: " n11 . n11 node-type  space n11 node-next @ .
    cr ." n12: " n12 . n12 node-type  space n12 node-next @ .
;

: node-next-clear ( node-addr -- )  node-next 0 swap !  ;

: clear-data ( -- )
    n4  node-next-clear
    n5  node-next-clear
    n6  node-next-clear
    n7  node-next-clear
    n8  node-next-clear
    n9  node-next-clear
    n10 node-next-clear
    n11 node-next-clear
    n12 node-next-clear
    0 l2 !
;

: add ( node list s-addr n )
    cr ." Add " 3 pick  node-type  space  type
    dup node-insert
    cr l2 node-traverse cr
;

: add ( node list s-addr n )
    cr ." Add " 3 pick  node-type  space  type
    tuck node-insert
    cr node-traverse cr
;

cr .( ==== First list, l1, built manually ==========================================)
l1 node-traverse cr

1 [IF]
cr .( ==== Second list, l2 =========================================================)

clear-data
cr ." Before adds: " .s
n4  l2 s" to empty list using n4 " add
cr ." After first add: " .s
n6  l2 s" to list using n6" add
n5  l2 s" to list using n5" add
n7  l2 s" to list using n7" add
n8  l2 s" to list using n8" add
n9  l2 s" to list using n9" add
n10 l2 s" to list using n10" add
n11 l2 s" to list using n11" add
n12 l2 s" to list using n12" add

cr .( ==== Second list, build 2  ===================================================)
clear-data

n4  l2 s" to empty list using n4" add
n5  l2 s" to list after existing node using n5" add
n6  l2 s" to list at front using n6" add

cr .( ==== Third list, build 3 ======================================================)
clear-data

n4  l2 s" to empty list using n4" add
n6  l2 s" to list before existing node n6" add
n9  l2 s" to list at end using n9" add

[THEN]