list.fs

\ linked list
\
\        link     data
\      +-------+-------+
\ 100  |  102  |  42   |          0 42 list-append 100
\      +-------+-------+          
\ 102  |  104  |  666  |           666 list-append 102
\      +-------+-------+          
\ 104  |  0    |  1337 | <- head  1337 list-append 104
\      +-------+-------+

vocabulary lists
lists definitions

\ list:node structure
0
dup constant list:link 1 cells +
dup constant list:data 1 cells +
constant list:node

: list->link    list:link + ;
: list->data    list:data + ;
: list->link@   list:link + @ ;
: list->data@   list:data + @ ;
: list->end?    list:link + 0= ;
: list->nend?   list:link + 0<> ;

: list:allocate list:node allocate throw ;
: list:erase    list:node erase ;
: list:data!    list:data + ! ;
: list:link!    list:link + ! ;

\ allocate new node and set data to u
: list:new ( u -- addr )
  list:allocate
  dup list:erase
  2dup list:data!
  nip
;

\ allocate new node with value u and append to head
\ leave new head at stack
: list-append ( addr1 u -- addr2 )
  dup list:new          \ addr1 u addr2 ; allocate new node with value 0
  rot                   \ u addr2 addr1
  dup 0<> if
    2dup list:link!
  then                  \ FIXME: below is messy
  drop                  \ u addr2
  dup rot               \ addr2 addr2 u
  swap                  \ addr2 u addr2
  list:data!
;

\ execute xt on every element of list
: list-apply ( xt addr -- )
  begin
    dup list->nend?
  while
    dup               \ xt addr addr
    2 pick execute    \ xt addr
    list->link@
  repeat
  2drop
;

\ execute xt on every element and create a new list
\ return tail of new list
: list-map ( xt addr -- head tail )
  0 swap              \ xt newnode curnode
  begin
    dup list->nend?
  while
    dup               \ xt newnode curnode curnode
    3 pick execute    \ xt newnode curnode x
    rot swap          \ xt curnode newnode x
    over 0= if
      list-append
      dup >r
    else
      list-append
    then              \ xt curnode newnode
    swap              \ xt newnode curnode
    list->link@
  repeat
  rot 2drop
  r>
;

: list-free ( addr -- )
  begin
    dup list->nend?
  while
    dup list->link@   \ curnode nextnode
    swap free         \ nextnode
  repeat
  free
;

\ test
: list-node-debug ( addr -- )
  ." list-node{ "                      cr
  ."   link: "    dup list->link@ hex. cr
  ."   data: "    dup list->data@ .    cr
  ." } " cr
  drop
;

: list-node-print-data ( addr -- )
  dup list->data@ .              \ FIXME: how to print without trailing space?
  list->nend? if ." , " then
;

variable tail

\ construct a list
0
42   list-append dup tail !
666  list-append
32   list-append
44   list-append
3434 list-append
666  list-append
1337 list-append
drop \ the head

tail @

\ print list
cr ." list1: "
dup ' list-node-print-data swap list-apply \ tail1

\ print list nodes with debug

cr ." list1 debug: " cr
dup ' list-node-debug swap list-apply

\ map a new list
: list-test-map-0 ( u -- )
  list->data@ 2 * ;

cr ." applying map word that doubles each number:" cr
dup ' list-test-map-0 swap list-map        \ tail1 head2 tail2

\ print the new list
cr ." list2: "
dup ' list-node-print-data swap list-apply \ tail1 head2 tail2

cr

\ free the new list
list-free
drop \ drop the head

\ free the previous list
list-free

bye