\ this is the memory management testsuite.
\ 
\ run it with   paflof < memory-testsuite.fs 2>/dev/null

s" memory.fs" included

\ dumps all free-list entries
\ useful for debugging.

: dump-freelist ( -- )
  ." Dumping freelist:" cr
  free-list @

  \ If the free list is empty we notify the user.
  dup 0= if ."   empty." drop cr exit then
  
  begin dup 0<> while
    dup ." entry 0x" .			\ print pointer to entry
    dup cell+ @ ." , next=0x" u.	\ pointer to next entry
    dup @ ." , size=0x" u. cr		\ len of current entry

    cell+ @
  repeat
  cr drop
  ;

\ simple testsuite. run testsuite-init to initialize
\ with some dummy memory in the dictionary.
\ run testsuite-test[1..3] for different tests.

: testsuite-init ( -- )
  here 40000 cell+ dup allot ( -- ptr len )
  init-mem

  ." start-mem = 0x" start-mem @ . cr
  ." end-mem   = 0x" end-mem @ . cr
  ." free-list = 0x" free-list @ . cr
  
  ." Memory management initialized." cr
  dump-freelist
  ;

: testsuite-test1 ( -- )
  ." Test No. 1: Allocating all available memory (256k)" cr

  40000 alloc-mem
  dup 0<> if 
    ." worked, ptr=0x" dup .
  else
    ." did not work."
  then
  cr

  dump-freelist
  ." Freeing memory." cr
  ." stack=" .s cr
  free-mem
  dump-freelist
  ;
  
: testsuite-test2 ( -- )
  ." Test No. 2: Allocating 5 blocks" cr
  4000 alloc-mem
  4000 alloc-mem
  4000 alloc-mem
  4000 alloc-mem
  4000 alloc-mem
  
  ." Allocated 5 blocks. Stack:" cr .s cr

  dump-freelist
  
  ." Freeing Block 2" cr
  3 pick free-mem dump-freelist

  ." Freeing Block 4" cr
  over free-mem dump-freelist

  ." Freeing Block 3" cr
  2 pick free-mem dump-freelist

  ." Cleaning up blocks 1 and 5" cr
  free-mem	\ Freeing block 5
  dump-freelist
  3drop		\ blocks 4, 3, 2
  free-mem
  
  dump-freelist
  ;

: testsuite-test3 ( -- )
  ." Test No. 3: freeing illegal address 0xdeadbeef." cr
  deadbeef free-mem
  dump-freelist
  ;
  
: testsuite ( -- )
  testsuite-init
  testsuite-test1
  testsuite-test2
  testsuite-test3
  ;

testsuite

bye