(    Title:  garbage collected record stack tests
      File:  gcrstack-test.fs
    Author:  David N. Williams
   Version:  0.9.2
   License:  Public Domain
  Log file:  gcrsgack.log
   Started:  January 19, 2011
   Revised:  January 27, 2021
)
decimal

[UNDEFINED] \\ [IF]
  : \\  ( -- )  -1 parse 2drop BEGIN refill 0= UNTIL ;
[THEN]
: .#  ( n -- )  cr ." #" . cr ;

s" gcrstack.fs"       INCLUDED
s" ttester-xf.fs"     INCLUDED
s" tester-display.fs" INCLUDED
s" xtester-errors.fs" INCLUDED
true VERBOSE !
true value SHOW-TDUMP

\ before the first displayed line
PFE-HOST IFORTH-HOST or [IF] ?.cr [THEN]

[UNDEFINED] BOUNDS [IF]  \ OF, Comus 
: BOUNDS  ( addr u -- addr+u addr )  over + swap ; [THEN]

?." Record space, garbage collection, and stack tests.

\ test records
create r1 1 , 2 ,
create r2 3 , 4 ,
create r3 5 , 6 ,
2 cells     constant /trec
/trec cell+ constant /tgrec

0 VALUE temp1
0 VALUE temp2

: tfree-rec ( ra -- )		  dup off cell+ off ;
: tcopy-rec ( src.ra dest.ra -- ) /trec move ;

: freed  ( -- freed.rec.data )  0 0 ;

\ TROUBLE-SHOOTING WORDS

: .gstat  ( 'gspace -- )
  >r VERBOSE @ IF
    ." gbuffer size: " r@ >/gbuf @ . ." bytes" cr
    ." gunused: " r@ gunused . ." bytes   " cr
    ." gdepth:  " r@ gdepth . cr
    base @ hex
    ." gbuffer: 0x" r@ >gbuf . cr
    ." gbreak:  0x" r@ >gbrkp @ . cr
    ." gsp:     0x" r@ >gsp @ . cr
    ." gsp0:    0x" r@ >gsp0 @ . cr
    ." gextra1: 0x" r@ >gextra1 @ . cr
    r@ ggarbage? IF ." There is some record garbage. "
    ELSE ." There is no record garbage. " THEN cr
    ." Garbage collection lock: "
    r@ >ggc-lock @ IF ." ON" ELSE ." OFF" THEN cr
    base !
  THEN r> drop ;

: dump-grecs  ( 'gspace -- )
  >r VERBOSE @ IF
    r@ r@ >/gbuf @ /gspace-header + cell+ ( #bytes) dump
    [ PFE-HOST ] [IF] cr [THEN]
    r@ .gstat THEN r> drop ;

: dump-rec  ( ra 'gspace -- )
  ." record: " >/grec @ cell- bounds ?DO i @ . 1 cells +LOOP cr ;

TESTING  make-gspace 0gspace
(
0GSPACE is implicitly tested via MAKE-GSPACE.
)

/tgrec cell+ 7 * constant /tbuf  \ stack slot for each tgrec

' tfree-rec ' tcopy-rec /trec /tbuf
   make-gspace VALUE trecs

: dump-trecs  trecs dump-grecs ;

SHOW-TDUMP [IF]
?." Empty record space used for testing:
dump-trecs ?.cr
[THEN]

t{ trecs >/gbuf @ -> /tbuf }t
t{ trecs >/grec @ -> /tgrec }t
t{ trecs >gfree-rec-xt @ -> ' tfree-rec }t
t{ trecs >gcopy-rec-xt @ -> ' tcopy-rec }t
t{ trecs >gbuf -> trecs /gspace-header + }t
t{ trecs >gbrkp @ -> trecs >gbuf }t
t{ trecs >gsp @   -> trecs >gbrkp @ trecs >/gbuf @ + }t
t{ trecs >gsp0 @  -> trecs >gsp @ }t
t{ trecs >ggbg @  -> false }t
t{ trecs >ggc-lock @ -> false }t

TESTING  gunused gdepth groom? gsp-- gsp++ (>gs) (gdrop)

: tunused   trecs gunused ;
: tdepth    trecs gdepth ;
: (>ts)     trecs (>gs) ;
: (tdrop)   trecs (gdrop) ;
: tgarbage? trecs ggarbage? ;
: troom?    trecs groom? ;
: tsp--     trecs gsp-- ;
: tsp++     trecs gsp++ ;
: tsp@      trecs >gsp @ ;
: tsp0@     trecs >gsp0 @ ;
: tbuf      trecs >gbuf ;
: tbrkp@    trecs >gbrkp @ ;

t{ tsp@ -> tsp0@ }t
t{ tsp@ tsp-- -> tsp@ cell+ }t
t{ tsp@ tsp++ -> tsp@ cell- }t
t{ tsp@ -> tsp0@ }t

t{ r2 (>ts) r1 (>ts) (tdrop) tdepth (tdrop) tdepth -> 1 0 }t

/tbuf aligned cell/ constant MAX-TBUF-CELLS

: almost-fill-push-ext  ( -- )
  MAX-TBUF-CELLS 1- 0 DO r3 trecs (>gs) LOOP ; 
 
t{ tdepth -> 0 }t
t{ almost-fill-push-ext tdepth -> MAX-TBUF-CELLS 1- }t
t{ cell troom? -> true }t
t{ r2 (>ts) tdepth -> MAX-TBUF-CELLS }t
t{ cell troom? -> false }t

: 0tspace  trecs 0gspace ;

: 00tspace
  ---
    For test dumps, it's occasionally nice to have a really
    clean slate, so this word actually zeroes the gbuffer.
  ---
  0tspace tbuf /tbuf 0 fill ;

t{ 00tspace -> }t

TESTING  ggc-off ggc-on ggc-lock@ ggc-lock!

: tgc-off    trecs ggc-off ;
: tgc-on     trecs ggc-on ;
: tgc-lock@  trecs ggc-lock@ ;
: tgc-lock!  trecs ggc-lock! ;

t{ trecs >ggc-lock @ -> false }t
t{ tgc-off trecs >ggc-lock @ tgc-lock@ -> true true }t
t{ tgc-on  trecs >ggc-lock @ tgc-lock@ -> false false }t
t{ true  tgc-lock! tgc-lock@ -> true }t
t{ false tgc-lock! tgc-lock@ -> false }t

TESTING  gs@ >gs new-grec >gs-copy is-grec in-gs make-ggarbage ggarbage?

: ts@      trecs gs@ ;
: >ts      trecs >gs ;
: new-trec trecs new-grec ;
: >ts-copy trecs >gs-copy ;
: is-trec  trecs is-grec ;
: in-ts    trecs in-gs ;

: backlink@  ( ra -- backlink )  cell- @ ;

0tspace
\ Uncomment to see underflow message.
\ ts@
t{ ' ts@ CATCH -> -2 }t

t{ r1 (>ts) ts@ ts@ tdepth -> r1 r1 1 }t
t{ r2 >ts tdepth ts@ -> 2 r2 }t
t{ r1 is-trec r2 is-trec r3 is-trec -> false false false }t
t{ tsp@ cell- in-ts tsp@ in-ts tsp@ cell+ in-ts
     tsp@ 2 cells + in-ts -> false true true false }t
\ There are no trecs.
t{ tbuf is-trec tbrkp@ cell- is-trec tbrkp@ is-trec -> false false false }t
t{ tunused -> /tbuf tdepth cells - }t

t{ tbrkp@ dup to temp1 tdepth to temp2 new-trec -> temp1 dup cell+ }t
t{ temp1 @ -> 0 }t  \ back link
t{ tdepth -> temp2 }t
t{ temp1 cell+ dup is-trec swap in-ts -> true false }t
\ t{ temp1 cell+ 2@ -> true true }t

t{ r3 is-trec -> false }t
t{ tunused to temp1 r3 >ts-copy tdepth -> 3 }t
t{ ts@ is-trec -> true }t
t{ ts@ backlink@ -> tsp@ }t
t{ ts@ 2@ -> 6 5 }t
t{ tunused -> temp1 cell- /tgrec - }t

0tspace
t{ r1 >ts-copy tgarbage? -> false }t
\ MAKE-GGARBAGE implicit in (GDROP)
t{ (tdrop) tgarbage? -> true }t

: almost-fill->ts  ( -- )  MAX-TBUF-CELLS 1- 0 DO r2 >ts LOOP ; 

0tspace
t{ almost-fill->ts -> }t
t{ cell troom? -> true }t
t{ r2 >ts tdepth -> MAX-TBUF-CELLS }t
t{ cell troom? tunused -> false 0 }t

\ Uncomment to see overflow message.
\ r1 >ts
t{ r1 ' >ts CATCH nip -> -2 }t

: r3-almost-fill-tspace  ( -- )
  /tbuf /tgrec cell+ / 1- 0 DO r3 >ts-copy LOOP ;

0tspace
t{ r3-almost-fill-tspace -> }t
t{ tunused -> /tgrec cell+ }t
t{ r3 >ts-copy tunused -> 0 }t

0tspace r3-almost-fill-tspace
\ Uncomment to see record not external message. 
\ ts@ >ts-copy
t{ ts@ ' >ts-copy CATCH nip -> -2 }t

t{ r2 >ts tunused -> /tgrec }t
\ Uncomment to see overflow message.
\ r1 >ts-copy
t{ r2 ' >ts-copy CATCH nip -> -2 }t

TESTING  g,ra gs>extgernaL TCONSTANT GVARIABLE g@

: t,ra        trecs g,ra ;
: ts>extern   trecs gs>extern ;
: t@          trecs g@ ;

: TCONSTANT ( "name" -- ) ( t: b -- )
  ts>extern ( ra) create ,
DOES>  ( t: -- b.ext )  @ (>ts)
;

\ GS>EXTERNAL is tested indirectly through TSCONSTANT	

\ debugging
: t.  ( t: b -- )   ts@ 2@ . . (tdrop) ; 

\ get external record data
: ts>rd  ( t: b -- s: data )  ts@ 2@ (tdrop) ;
: rd1  r1 2@ ;   : rd2  r2 2@ ;   : rd3  r3 2@ ;  

0tspace
r1 >ts-copy
t{ here t,ra dup 2@ tdepth -> here /trec - dup 2 1 0 }t

0tspace
t{ r3 >ts-copy tconstant rc3 tdepth tgarbage? -> 0 true }t
t{ rc3 ts@ is-trec tdepth -> false 1 }t
t{ ts@ r3 = -> false }t
t{ ts>rd -> rd3 }t

0tspace
t{ r2 >ts tconstant rc2 tdepth tgarbage? -> 0 false }t
t{ rc2 ts@ r2 = tdepth -> true 1 }t
t{ ts>rd -> rd2 }t

\ No TVARIABLE because gvariables are the same for any type.
t{ gvariable tv1 tv1 t@ tdepth ts@ (tdrop) -> 1 0 }t

TESTING  g! free-grecs

: t!          trecs g! ;
: free-trecs  trecs free-grecs ;

: on-tstack  ( ra -- flag )
  tsp0@ tsp@ ?DO
    ( ra) dup i @ = IF ( ra) drop true UNLOOP EXIT THEN  
  cell +LOOP
  ( ra) drop false ;

: was-on-tstack  ( ra -- flag )
  ---
    Use only when ra is the most recently popped tstack entry,
    which hasn't been clobbered.
  ---
  tsp-- tsp@ @ = tsp++ ;

: &deepest  ( ra -- addr|0 )
  ( ra) dup on-tstack 0= IF drop false EXIT THEN
  tsp@ tsp0@ DO
    ( ra) dup i @ = IF ( ra) drop i UNLOOP EXIT THEN
  -1 cells +LOOP ( ra) drop false ;

0tspace
t{ r1 >ts-copy ts@ (tdrop) tdepth tgarbage? -> tbuf cell+ 0 true }t
0tspace
t{ r1 >ts-copy ts@ on-tstack -> true }t
t{ ts@ (>ts) ts@ &deepest -> tsp@ cell+ }t
t{ tsp++ ts@ &deepest -> tsp@ }t

0tspace
t{ r1 >ts-copy ts@ (tdrop) was-on-tstack -> true }t

\ In the following, old and new refer to the old contents of a
\ variable being stored into and the new contents being stored
\ into it.

0 value var
0 value ra.old
0 value unused.prev
0 value depth.prev
0 value ra.new
0 value ra.copy
0 value backlink.old
0 value backlink.new

\ Predicates to be used in the definition of T!?.  The runtime
\ stack effect is the same for all:  ( -- flag )

\ initial state predicates

: old-extern
  ra.old is-trec 0= ;

: new-extern
  ra.new is-trec 0=  ;
 
: new-is-old
  ra.new ra.old = ;

: old-intern-v
  ra.old is-trec dup IF backlink.old var = and THEN ;

: new-intern-v
  ra.new is-trec dup IF backlink.new var = and THEN ;

: new-intern-tos  \ linked to tos
  ra.new is-trec
  IF ra.new was-on-tstack backlink.new tsp@ cell- = and
  ELSE false THEN ;

: new-intern-deep  \ linked deeper than tos
  ra.new is-trec
  IF ra.new &deepest backlink.new =
  ELSE false THEN ;

: new-intern-v'
  ra.new is-trec   backlink.new var <> and   backlink.new 0<> and
  backlink.new tsp@ tsp0@ within 0= and ;

\ final state predicates

: no-copy
  tdepth 1+ depth.prev =
  tunused unused.prev cell+ = and ;

: yes-copy
  tdepth 1+ depth.prev =
  tunused /tgrec + cell- unused.prev = and ; 

: old-in-var
  ra.old var @ = ;

: new-in-var
  ra.new var @ = ;

: copy-in-var
  ra.copy var @ = ;

: old-is-garbage
  ra.old backlink@ 0= ;

: old-stack-linked
  ra.old on-tstack
  IF ra.old backlink@ ra.old &deepest = ELSE false THEN ;

: old-relinked
  backlink.old ra.old backlink@ <> ;

: new-relinked
  backlink.new ra.new backlink@ <> ;

: new-var-linked
  ra.new backlink@ var = ;

: copy-var-linked
  ra.copy backlink@ var = ;

\ the word that uses the predicates

: t!?  ( gvar.dfa -- case flag ) ( t: ra -- )
---
An independent, orthogonal rewrite of the G! logic, which
invokes T! and checks the change in the gspace and gvariable
state.  The flag is true when the result is correct.
---
\  tgarbage? ABORT" ***T!? must be run without gargage."

  dup            to var
  var @          to ra.old
  ts@            to ra.new
  tbrkp@ cell+   to ra.copy    \ in case there's copying
  tunused        to unused.prev
  tdepth         to depth.prev

  ra.old is-trec IF ra.old backlink@ to backlink.old THEN
  ra.new is-trec IF ra.new backlink@ to backlink.new THEN
  ( gvar.dfa t: ra) t!
  true CASE
\ 1.
  old-extern new-is-old and
  OF 1 no-copy old-in-var and ENDOF
\ 2.
  old-intern-v new-is-old and
  OF 2 no-copy old-in-var and old-is-garbage 0= and
     old-relinked 0= and ENDOF

\ From here on, ra.new <> ra.old.

\ 3.
  old-extern new-extern and
  OF 3 no-copy new-in-var and ENDOF
\ 4.
  old-extern new-intern-deep and
  OF 4 no-copy new-in-var and new-var-linked and ENDOF
\ 5.
  old-extern new-intern-tos and
  OF 5 no-copy new-in-var and new-var-linked and ENDOF
\ 6. & 7.
  old-intern-v new-extern and
  OF no-copy new-in-var and
     old-is-garbage IF 6 >r true ELSE 7 >r old-stack-linked THEN
     and r> swap ENDOF
\ 8.
  old-intern-v new-intern-deep and
  OF 8 no-copy new-in-var and old-is-garbage and new-var-linked and ENDOF 
\ 9.
  old-intern-v new-intern-tos and
  OF 9 no-copy new-in-var and old-is-garbage and new-var-linked and ENDOF 
\ 10.
  old-extern new-intern-v' and
  OF 10 yes-copy copy-in-var and new-relinked 0= and copy-var-linked and ENDOF
\ 11. & 12.
  old-intern-v new-intern-v' and
  OF yes-copy copy-in-var and new-relinked 0= and
     old-is-garbage IF 11 >r true ELSE 12 >r old-stack-linked THEN
     and r> swap ENDOF

  ABORT" ***cases not exhaustive"
  ENDCASE ;

: is-intern  ( bna -- flag )  is-trec ;
: is-extern  ( bna -- flag )  is-trec 0= ;

00tspace

\ Garbage collection is not tested so far, but eventually it
\ will have been tested by a previous run of the entire test
\ suite, whereupon this will do what it's supposed to:

tgc-off
align here dup true , true ,
>ts tconstant rc0
    constant  r0a  \ pfe uses the name r0
t{ rc0 ts@ (tdrop) is-extern -> true  }t
t{ rc0 ts>rd -> true true }t
t{ tgarbage? -> false }t

\ INSPECT THE FOLLOWING to check that Cases 1-12 are covered.

\ 1. setup, ensure that bv1 holds external rc0 ra
t{ tunused rc0 tv1 t! tdepth tgarbage? -> tunused 0 false }t
t{ tv1 @ -> rc0 ts@ (tdrop) }t

\ 1. old and new external and identical
t{ rc0 tv1 t!? -> 1 true }t

t{ tv1 @ is-extern -> true }t
t{ tdepth -> 0 }t

\ 4. old external, new internal linked below top of bstack
t{ r1 >ts-copy ts@ (>ts) tv1 t!? -> 4 true }t

t{ tv1 @ is-intern -> true }t
t{ tdepth -> 1 }t

\ 5. setup
t{ rc0 tv1 t!? -> 7 true }t

t{ tv1 @ is-extern -> true }t
t{ tdepth -> 1 }t

\ 5. old external, new internal linked to top of bstack only
t{ tv1 t!? -> 5 true }t

t{ tv1 @ is-intern -> true }t

\ 2. old and new internal and identical
t{ tv1 @ (>ts) tv1 t!? -> 2 true }t

t{ tv1 @ is-intern -> true }t

gvariable tv2

\ 3. old external, new external and different
t{ rc3 tv2 t!? -> 3 true }t

t{ tv2 @ is-extern -> true }t

\ 6. old internal in variable, new external
\ output: old is garbage 
t{ rc0 ( new) tv1 ( old) t!? -> 6 true }t

t{ tv1 @ is-extern -> true }t

\ 7. setup
t{ r1 >ts-copy tv1 t!? -> 5 true }t
t{ tv1 @ is-intern -> true }t
t{ tv1 @ (>ts) tdepth -> 1 }t

\ 7. old internal in variable and on stack, new external
\ output: old is linked to stack 
t{ rc0 ( new) tv1 ( old) t!? -> 7 true }t

t{ tv1 @ is-extern (tdrop) tdepth -> true 0 }t

\ 10. setup
t{ r1 >ts-copy tv2 t!? -> 5 true }t
t{ tv1 @ is-extern tv2 @ is-intern -> true true }t

\ 10. old external, new internal in different variable
t{ tv2 t@ ( new) tv1 ( old) t!? -> 10 true }t

t{ tv1 @ is-intern tv2 @ is-intern -> true true }t
t{ tdepth -> 0 }t

\ 11. old internal in variable, new internal in different variable
\ output: old is garbage
t{ tv2 t@ ( new) tv1 ( old) t!? -> 11 true }t

t{ tv1 @ is-intern tv2 @ is-intern -> true true }t
t{ tdepth -> 0 }t

\ 8. old internal in variable, new internal linked below top of stack
\ output: old is garbage
t{ r1 >ts-copy ts@ (>ts) tv1 t!? -> 8 true }t

\ 9. setup
t{ (tdrop) tv1 @ is-intern tdepth -> true 0 }t

\ 9. old internal in variable, new internal on tos only
\ output: old is garbage
t{ r1 ( new) >ts-copy tv1 ( old) t!? -> 9 true }t

t{ tv1 @ is-intern -> true }t
t{ tdepth -> 0 }t

\ 12. old internal in variable and on stack,
\     new internal in different variable
\ output: old is linked to stack 

t{ tv2 @ (>ts) tv1 @ (>ts) -> }t
t{ tv2 t!? -> 12 true }t

: tspace-clear?  ( -- flag )
  tsp@ tsp0@ =   tbrkp@ tbuf = and ;

t{ tv1 @ is-intern tv2 @ is-intern -> true true }t
t{ tdepth tspace-clear? -> 1 false }t

t{ free-trecs tspace-clear? -> true }t
t{ tv1 @ is-extern tv2 @ is-extern   -> true true }t
t{ tv1 @ tv2 @ -> 0 0 }t

SHOW-TDUMP [IF]
?." You should see an empty gbuffer, with zeroes in all cells except
?." for backlinks to two variables, a backlink into the former gstack,
?." and a gra formerly on the gstack, pointing just after one of
?." the variable backlink fields.  Zeroes in record fields indicate
?." that TFREE-REC was called.

dump-trecs
hex ?.( &tv1: 0x) tv1 . ?.(    &tv2: 0x) tv2 . ?.cr ?.cr
decimal
[THEN]

TESTING  collect-ggarbage ggc-off ggc-on ggc-lock@ ggc-lock!

: collect-tgarbage  trecs collect-ggarbage ;

t{ 00tspace tspace-clear? -> true }t

\ No systematic checks for tstack underflow or overflow:
: (tdup)   ( t: ra -- ra ra )  ts@ (>ts) ;

: tgrecs  ( +n -- u )  /tgrec * ;
: tgrec@  ( ra -- rdata backlink )  dup >r cell+ 2@ r> @ ;

---
Make a garbage hole at the beginning of the gbuffer, a hole
between bound records, and a hole as the last record in the
buffer, with some duplication on the tstack, and something
stored in a gvariable.
---
  rc0
  r1 >ts-copy (tdrop)       \ beginning hole
  r2 >ts-copy (tdup)
  r1 >ts-copy (tdrop)       \ double middle hole
  r1 >ts-copy (tdrop)
  r3 >ts-copy (tdup) tv1 t!
  r1 >ts-copy (tdrop)       \ end hole

t{ tgarbage? -> true }t
t{ tdepth    -> 4 }t
t{ tbrkp@    -> tbuf 6 tgrecs + }t
t{ tunused   -> /tbuf 6 tgrecs - 4 cells - }t

\ verify bound record and garbage data
t{ tbuf 0 tgrecs + tgrec@ -> freed 0 }t             \ 1st hole
t{ tbuf 1 tgrecs + tgrec@ -> rd2 tsp0@ 2 cells - }t \ r2-copy bound to tstack
t{ tbuf 2 tgrecs + tgrec@ -> freed 0 }t             \ 2nd hole, 2 grecs
t{ tbuf 3 tgrecs + tgrec@ -> freed 0 }t
t{ tbuf 4 tgrecs + tgrec@ -> rd3 tv1 }t             \ r3-copy bound to tv1
t{ tbuf 5 tgrecs + tgrec@ -> freed 0 }t             \ 3rd hole

\ verify tstack ra's
t{ tsp@ 0 cells + @ -> tbuf 4 tgrecs + cell+ }t  \ r3-copy
t{ tsp@ 1 cells + @ -> tbuf /tgrec + cell+ }t    \ r2-copy
t{ tsp@ 2 cells + @ -> tbuf /tgrec + cell+ }t    \ r2-copy (same)
t{ tsp@ 3 cells + @ -> r0a }t		         \ r0-ext

SHOW-TDUMP [IF]
?." You should see a garbage hole at the start of the gbuffer, a record
?." bound to and duplicated on the gstack, a garbage hole with two
?." records, a record bound to the variable TV1 and duplicated on the
?." top of the gstack, and a garbage hole with one record.  The fourth,
?." deepest record on the gstack is external."

dump-trecs
?.( &tv1:    0x) tv1 hex . decimal ?.cr
[THEN]

\ 2 new grecs triggers gc
t{ r3 >ts-copy r3 >ts-copy -> }t
t{ tdepth    -> 6 }t
t{ tgarbage? -> false }t
t{ tbrkp@    -> tbuf 4 tgrecs + }t
t{ tunused   -> /tbuf 4 tgrecs - 6 cells - }t

\ verify bound record data
t{ tbuf 0 tgrecs + tgrec@ -> rd2 tsp0@ 2 cells - }t  \ r2-copy bound to tstack
t{ tbuf 1 tgrecs + tgrec@ -> rd3 tv1 }t              \ r3-copy bound to tv1
t{ tbuf 2 tgrecs + tgrec@ -> rd3 tsp@ 1 cells + }t   \ r3-copy bound to tstack
t{ tbuf 3 tgrecs + tgrec@ -> rd3 tsp@ }t             \ r3-copy bound to tstack

\ verify tstack ra's
t{ tsp@ 0 cells + @ -> tbuf 3 tgrecs + cell+ }t  \ r3-copy
t{ tsp@ 1 cells + @ -> tbuf 2 tgrecs + cell+ }t  \ r3-copy (different)
t{ tsp@ 2 cells + @ -> tbuf 1 tgrecs + cell+ }t  \ r3-copy (different)
t{ tsp@ 3 cells + @ -> tbuf 0 tgrecs + cell+ }t  \ r2-copy
t{ tsp@ 4 cells + @ -> tbuf 0 tgrecs + cell+ }t  \ r2-copy (same)
t{ tsp@ 5 cells + @ -> r0a }t                    \ r0-ext

SHOW-TDUMP [IF]
?." Now we have triggered a garbage collection by copying in two more
?." records, so you should see the holes removed."

dump-trecs
?.( &tv1:    0x) tv1 hex . decimal ?.cr
[THEN]

t{ collect-tgarbage -> false }t
t{ (tdrop) (tdrop) (tdrop) (tdrop) (tdrop) (tdrop) tdepth -> 0 }t

\ Now it's all garbage except for the next to last record, which
\ is stored in tv1.
t{ tgarbage? collect-tgarbage tgarbage? -> true true false }t

\ Only the tv1 record is left.
t{ tv1 @ is-trec tspace-clear? -> true false }t
t{ rc0 tv1 t! tgarbage? -> true }t

\ Now it's garbage, too.
t{ collect-tgarbage tgarbage? -> true false }t
t{ tspace-clear? -> true }t

---
Next we test COLLECT-TGARBAGE with the first record alive,
followed by several garbage records.
---
  00tspace
  r2 >ts-copy
  r1 >ts-copy (tdrop)
  r3 >ts-copy (tdrop)
  r1 >ts-copy (tdrop)

t{ collect-tgarbage (tdrop) collect-tgarbage -> true true }t
t{ tspace-clear? -> true }t

---
Test with nothing but garbage.
---
  00tspace
  r2 >ts-copy (tdrop)
  r1 >ts-copy (tdrop)
  r3 >ts-copy (tdrop)

t{ collect-tgarbage tspace-clear? -> true true }t

\ GC LOCK TESTS

\ Make some garbage.
t{ r2 >ts-copy (tdrop) tgc-off -> }t
t{ tgc-lock@ -> true }t

---
\ Uncomment see the error message for attempting gc when locked.
---
\ collect-tgarbage
t{ ' collect-tgarbage CATCH -> -2 }t

t{ tgc-on collect-tgarbage -> true }t
t{ tgc-lock@ -> false }t

t{ true  tgc-lock! tgc-lock@ -> true }t
t{ false tgc-lock! tgc-lock@ -> false tgc-on }t

t{ tspace-clear? collect-tgarbage -> true false }t

TESTING  gdrop g2drop g3drop gdup g2dup gswap gnip gover gtuck gpick gs2@ gs3@
---
These tests do no gvariable storage, and do not engage garbage
collection.
---

: tdrop  trecs gdrop ;  \ needed for => and }= 

0tspace
t{ rc2 tdrop tdepth -> 0 }t
t{ rc2 rc3 tdrop ts@ 2@ tdepth -> rd2 1 }t

---
The following definitions for  ={, =>, and }= fake tstack tests
by transferring tstack results to the data stack, and comparing
them to goals on the data stack.
---

: ={  ( xinitials -- ) ( t: tinitials -- )  t{ ;

0 value depth0
: reverse  ( i*x -- i*x' )   \ tested dnw 30-Jan-2011
  ---
    Reverse the top DEPTH - DEPTH0 stack elements.
  ---
  depth depth0 u> IF depth depth0 - 1- roll >r RECURSE r> THEN ;

: => ( xresults -- ) ( t: tresults -- )
  depth to depth0 tdepth 0 ?DO ts@ 2@ swap tdrop LOOP reverse -> ;

: }=  ( xresults -- xinitials ) ( t: tresults -- )
  depth to depth0 tdepth 0 ?DO ts@ 2@ swap tdrop LOOP reverse }t ;

: t2drop  trecs g2drop ;
: t3drop  trecs g3drop ;
: tdup    trecs gdup ;
: t2dup   trecs g2dup ;
: tswap   trecs gswap ;
: tnip    trecs gnip ;
: tover   trecs gover ;
: ttuck   trecs gtuck ;
: tpick   trecs gpick ;
: ts2@    trecs gs2@ ;
: ts3@    trecs gs3@ ;

r1 >ts tconstant rc1
\ records bound to tstack
: rb0  ( t: -- 'rb0 )  rc0 ts@ (tdrop) >ts-copy ;
: rb3  ( t: -- 'rb3 )  rc3 ts@ (tdrop) >ts-copy ;

0tspace
={ rc0 ts@ 2@ 2constant rd0 (tdrop) => }=

={ rc1 tdrop => }=
={ rc1 rc1 tdrop => rc1 }=
={ rc1 rc1 t2drop => }=
={ rc1 rc2 rc3 t2drop => rc1 }=
={ rc1 rc2 rc3 t3drop => }=
={ rc1 tdup => rc1 rc1 }=
={ rc1 rc2 t2dup => rc1 rc2 rc1 rc2 }=
={ rc1 rc2 tswap => rc2 rc1 }=
={ rc1 rc2 tnip  => rc2 }=
={ rc1 rc2 tover => rc1 rc2 rc1 }=
={ rc1 rc2 ttuck => rc2 rc1 rc2 }=
={ rc1 0 tpick => rc1 rc1 }=
={ rc1 rc2 1 tpick => rc1 rc2 rc1 }=
={ rb0 rc1 ts2@ 2@ rot 2@ => rc0 rc1 rd1 rd0 }=

={ rb0 rc1 rc2 ts3@ 2@ 2swap 2@ rot 2@
   => rc0 rc1 rc2 rd2 rd1 rd0 }=

TESTING  gexchange grot -grot

: texchange  trecs gexchange ;
: trot	     trecs grot ;
: -trot	     trecs -grot ;

={ rc0 rc1 0 1 texchange => rc1 rc0 }=
={ rc0 rc1 1 0 texchange => rc1 rc0 }=
={ rc0 rc2 rc1 rc1     1 3 texchange => rc1 rc2 rc0 rc1 }=
={ rc0 rc2 rc3 rc1 rc2 4 1 texchange => rc1 rc2 rc3 rc0 rc2 }=

\ all nondynamic -- see link tests
={ rc0 rc0 rc2 trot  => rc0 rc2 rc0 }=
={ rc0 rc1 rc0 trot  => rc1 rc0 rc0 }=
={ rc0 rc1 rc1 trot  => rc1 rc1 rc0 }=
={ rc0 rc1 rc2 trot  => rc1 rc2 rc0 }=
={ rc0 rc0 rc2 -trot => rc2 rc0 rc0 }=
={ rc0 rc1 rc0 -trot => rc0 rc0 rc1 }=
={ rc0 rc1 rc1 -trot => rc1 rc0 rc1 }=
={ rc0 rc1 rc2 -trot => rc2 rc0 rc1 }=

TESTING  relinking: gswap gexchang grot -grot

\ We don't claim to have exercised all paths in the code.

0tspace tgc-off

={ gvariable tv rc0 ts@ (tdrop) >ts-copy tv t! => }=

: th-blink  ( i -- blink_i ) ( t: a_i ... a_0 -- a_i ... a_0 )
  tpick ts@ (tdrop) backlink@ ;

: blinks  ( u -- blink_[u-1] ... blink_0 )
  1- 0 swap ?DO i th-blink -1 +LOOP ;

: th-sp@  ( i -- sp_i ) ( t: a_i ... a_0 -- a_i ... a_0 )
   cells tsp@ + ;

: rb1  ( t: -- 'rb1 )  rc1 ts@ (tdrop) >ts-copy ;
: rb2  ( t: -- 'rb2 )  rc2 ts@ (tdrop) >ts-copy ;

={ tv t@ rc2 tswap tv @ backlink@
   => rc2 tv t@ tv @ backlink@ }=

={ rc2 tv t@ tswap tv @ backlink@
   => tv t@ rc2 tv @ backlink@ }=

={ rc0 rb3 0 th-blink tswap 1 th-blink
   => rc3 rc0 tsp@ dup cell+ }=

={ rb0 rb3 0 th-blink 1 th-blink tswap
   0 th-blink 1 th-blink
   => rc3 rc0 tsp@ dup cell+ 2dup }=

={ rb0 rb3 tover 1 th-blink 0 th-blink tswap
   0 th-blink 1 th-blink
   => rc0 rc0 rc3 tsp@ cell+ dup cell+ tsp@ dup 2 cells + }=

0tspace tgc-off

={ rc0 rb3 0 th-blink 0 1 texchange 1 th-blink
      => rc3 rc0 tsp@ dup cell+ }=

={ rb0 rb3 0 th-blink 1 th-blink 1 0 texchange
    0 th-blink 1 th-blink
      => rc3 rc0 tsp@ dup cell+ 2dup }=

={ rb3 rb3 rc0 1 th-blink 2 th-blink 1 2 texchange
    1 th-blink 2 th-blink
      => rc3 rc3 rc0 tsp@ cell+ dup cell+ 2dup }=

={ rb0 rc2 rc1 rb3 rc2 1 th-blink 4 th-blink 1 4 texchange
  1 th-blink 4 th-blink
    => rc3 rc2 rc1 rc0 rc2 tsp@ cell+ dup 3 cells + 2dup }=

\ rot and -rot dynamic tests

0tspace tgc-off
={ rb0 tdup rb2 3 blinks trot 3 blinks
   => rb0 rb2 rb0 2 th-sp@ dup 0 th-sp@  2 th-sp@ 1 th-sp@ over }=

0tspace tgc-off
={ rb0 rb1 tover 3 blinks trot 3 blinks 
    => rb1 rb0 rb0 2 th-sp@ 1 th-sp@ over 2 th-sp@ 1 th-sp@ dup }=

0tspace tgc-off
={ rb0 rb1 tdup 3 blinks trot 3 blinks
   => rb1 rb1 rb0 2 th-sp@ 1 th-sp@ dup 2 th-sp@ dup 0 th-sp@  }=

0tspace tgc-off
={ rb0 rb1 rb2 trot 3 blinks
   => rb1 rb2 rb0 2 th-sp@ 1 th-sp@ 0 th-sp@ }=

0tspace tgc-off
={ rb0 tdup rb2  -trot 3 blinks => rb2 rb0 rb0 2 th-sp@ 1 th-sp@ dup }=

0tspace tgc-off
={ rb0 rb1 tover -trot 3 blinks => rb0 rb0 rb1 2 th-sp@ dup 0 th-sp@ }=

0tspace tgc-off
={ rb0 rb1 tdup  -trot 3 blinks => rb1 rb0 rb1 2 th-sp@ 1 th-sp@ over }=

0tspace tgc-off
={ rb0 rb1 rb2 -trot 3 blinks
   => rb2 rb0 rb1 2 th-sp@ 1 th-sp@ 0 th-sp@ }=

TESTING  exceptions
---
Some of the tests in this section implicitly, albeit very
weakly, verify the rule that exceptions leave record space in a
valid state.  Often they leave it unchanged, including the
bstack, from its state just before execution of the word, up to
garbage collection.  But the implementation especially is
allowed to temporarily push onto the bstack, so something extra
may be there at the point of an exception.
---

: nip2   nip nip ;

0tspace
\ Uncomment a line to see the record stack underflow message.
\ tdrop
T{ ' tdrop CATCH -> -2 }T
\ t2drop
T{ ' t2drop CATCH -> -2 }T
\ rc1 t2drop
T{ rc1 ' t2drop CATCH -> -2 }T
\ tdup
T{ ' tdup CATCH -> -2 }T
\ t2dup
T{ ' t2dup CATCH -> -2 }T
\ rc1 t2dup
T{ rc1 ' t2dup CATCH -> -2 0tspace }T
\ tswap
T{ ' tswap CATCH -> -2 }T
\ rc1 tswap
T{ rc1 ' tswap CATCH -> -2 0tspace }T
\ tnip
T{ ' tnip CATCH -> -2 }T
\ rc1 tnip
T{ rc1 ' tnip CATCH -> -2 0tspace }T
\ tover
T{ ' tover CATCH -> -2 }T
\ rc1 tover
T{ rc1 ' tover CATCH -> -2 0tspace }T
\ ttuck
T{ ' ttuck CATCH -> -2 }T
\ 0 tpick
T{ 0 ' tpick CATCH nip -> -2 }T
\ rc1 1 tpick
\ ts2@
t{ ' ts2@ CATCH -> -2 }t
\ rc1 ts2@
t{ rc1 ' ts2@ CATCH -> -2 0tspace }t

\ 0 0 texchange
T{ 0 0 ' texchange CATCH nip2 -> -2 }T
\ rc2 1 0 texchange
T{ rc2 1 0 ' texchange CATCH nip2 -> -2 0tspace }T
\ rc2 tdup tdup 0 3 texchange
T{ rc2 tdup tdup 0 3 ' texchange CATCH nip2 -> -2 0tspace }T
\ rc2 tdup tdup 3 0 texchange
T{ rc2 tdup tdup 3 0 ' texchange CATCH nip2 -> -2 0tspace }T
\ rc2 tdup tdup 3 3 texchange
T{ rc2 tdup tdup 3 3 ' texchange CATCH nip2 -> -2 0tspace }T

\ trot
T{ ' trot CATCH -> -2 }T
\ -trot
T{ ' -trot CATCH -> -2 0tspace }T
\ rc0 trot
T{ rc0 ' trot CATCH -> -2 0tspace }T
\ rc0 -trot
T{ rc0 ' -trot CATCH -> -2 0tspace }T
\ rc0 rc1 trot
T{ rc0 rc1 ' trot CATCH -> -2 0tspace }T
\ rc0 rc1 -trot
T{ rc0 rc1 ' -trot CATCH -> -2 0tspace }T

?.xt-errors GFORTH-HOST [IF] ?.cr [THEN]