needs lib/struct lib/bit lib/psrs mem/mark mem/arena
unit mem/cons

struct Cons { uint car cdr ; }

$1000 const CONSCNT \ must be divisible by 32
CONSCNT newmarklist const keeplist
create pool CONSCNT 8* allot
newarena bindrun1 leakarena1

code isgccons? ( a -- f *A* )
  pool i) -, CONSCNT 8* i) <) if,
    7 i) &, ifz, 1 i) @, exit, then then
  0 i) @, exit,
: iscons? ( a -- f *A* )
  dup 3 and if drop 0 else
    dup isgccons? if drop 1 else leakarena1 withinarena? then then ;
: iscons# iscons? not ?abort"cons expected" ;

code gcidx ( cons -- idx ) pool i) -, 3 i) >>, exit,
\ we want to avoid blowing the stack on recursion, so we loop, but because both
\ elements of the pair are potentially cons, we use recursion on one of them. We
\ choose the first element because cons links are generally the second element.
: ?markusedall ( a -- )
  begin dup isgccons? while dup gcidx keeplist ?mark not while ( cons )
    dup car ?markusedall cdr repeat then ( cons ) drop ;

variable consrefLL
: consref value consrefLL lladd CURWORD @ scryfind# , ;

: ensureleakspace leakarena1 ensurenext ;
: leak ( cons -- cons )
  dup isgccons? if
    dup car n"LEAK" = if cdr else
      8 leakarena1 allot@ >r ( cons V1=leaked )
      dup doto car n"LEAK" | ( cons car )
      over doto cdr r@ | ( cons car cdr )
      leak swap leak ( cons cdr car )
      2dup r@ !+ ! ( cons cdr car )
      rot !+ ! r> then then ;

:~ ( a u -- ) 0 do @+ ?markusedall loop drop ;
: gc ( -- )
  keeplist unmarkall
  scnt ps[] ~
  rcnt rs[] ~
  consrefLL begin @ ?dup while ( ll ) dup 4+ @ @ ?markusedall repeat ;

\ find a free slot. If found, mark it as used and yield its address in the pool
: getslot ( -- a-or-0 )
  keeplist findunmarked if dup keeplist mark 8* pool + else 0 then ;
: getslot# ( -- a )
  getslot ?dup not if gc getslot then
  ?dup not ?abort"out of cons memory" ;

: cons ( car cdr -- cons ) getslot# A! rot> A> to cdr A> to car ;
: append ( cons car -- newcons ) 0 cons >r ?dup if r@ swap to cdr then r> ;
:~ A! car A> cdr ;
: carcdr ( cons -- car cdr ) dup iscons# ~ ;
: ?carcdr ( a -- car cdr 1 OR a 0 ) dup iscons? if ~ 1 else 0 then ;
:~ A! cdr A> car ;
: cdrcar ( cons -- cdr car ) dup iscons# ~ ;
: ?cdrcar ( a -- cdr car 1 OR a 0 ) dup iscons? if ~ 1 else 0 then ;
: ?single ( a -- x 1 OR a 0 )
  dup ?carcdr if if drop 0 else nip 1 then else drop 1 then ;
: single# ?single not ?abort"single cons expected" ;
: tail ( list -- cons ) 0 swap begin ?dup while nip dup cdr repeat ;
: length ( list -- cnt ) 0 >r begin ?dup while doto V1 1+ | cdr repeat r> ;

: conscnt ( -- n ) keeplist markcnt ;

: islist? ( a -- f )
  ?carcdr if nip ?dup if islist? else 1 then else drop 0 then ;

alias abort .cons
: .list ( cons -- )
  ."(" begin
	cdrcar dup iscons? if .cons else . then ( cdr )
    dup iscons? dup if spc> then not until ( n )
  ?dup if spc> . then .")" ;
: .pair ( cons -- ) ."(" cdrcar .cons ." . " .cons .")" ;
:realias .cons ( cons -- )
  dup iscons? if dup islist? if .list else .pair then else . then ;