qemu/roms/openbios/forth/testsuite/memory-testsuite.fs

   1 \ this is the memory management testsuite.
   2 \
   3 \ run it with   paflof < memory-testsuite.fs 2>/dev/null
   4
   5 s" memory.fs" included
   6
   7 \ dumps all free-list entries
   8 \ useful for debugging.
   9
  10 : dump-freelist ( -- )
  11   ." Dumping freelist:" cr
  12   free-list @
  13
  14   \ If the free list is empty we notify the user.
  15   dup 0= if ."   empty." drop cr exit then
  16
  17   begin dup 0<> while
  18     dup ." entry 0x" .                  \ print pointer to entry
  19     dup cell+ @ ." , next=0x" u.        \ pointer to next entry
  20     dup @ ." , size=0x" u. cr           \ len of current entry
  21
  22     cell+ @
  23   repeat
  24   cr drop
  25   ;
  26
  27 \ simple testsuite. run testsuite-init to initialize
  28 \ with some dummy memory in the dictionary.
  29 \ run testsuite-test[1..3] for different tests.
  30
  31 : testsuite-init ( -- )
  32   here 40000 cell+ dup allot ( -- ptr len )
  33   init-mem
  34
  35   ." start-mem = 0x" start-mem @ . cr
  36   ." end-mem   = 0x" end-mem @ . cr
  37   ." free-list = 0x" free-list @ . cr
  38
  39   ." Memory management initialized." cr
  40   dump-freelist
  41   ;
  42
  43 : testsuite-test1 ( -- )
  44   ." Test No. 1: Allocating all available memory (256k)" cr
  45
  46   40000 alloc-mem
  47   dup 0<> if
  48     ." worked, ptr=0x" dup .
  49   else
  50     ." did not work."
  51   then
  52   cr
  53
  54   dump-freelist
  55   ." Freeing memory." cr
  56   ." stack=" .s cr
  57   free-mem
  58   dump-freelist
  59   ;
  60
  61 : testsuite-test2 ( -- )
  62   ." Test No. 2: Allocating 5 blocks" cr
  63   4000 alloc-mem
  64   4000 alloc-mem
  65   4000 alloc-mem
  66   4000 alloc-mem
  67   4000 alloc-mem
  68
  69   ." Allocated 5 blocks. Stack:" cr .s cr
  70
  71   dump-freelist
  72
  73   ." Freeing Block 2" cr
  74   3 pick free-mem dump-freelist
  75
  76   ." Freeing Block 4" cr
  77   over free-mem dump-freelist
  78
  79   ." Freeing Block 3" cr
  80   2 pick free-mem dump-freelist
  81
  82   ." Cleaning up blocks 1 and 5" cr
  83   free-mem      \ Freeing block 5
  84   dump-freelist
  85   3drop         \ blocks 4, 3, 2
  86   free-mem
  87
  88   dump-freelist
  89   ;
  90
  91 : testsuite-test3 ( -- )
  92   ." Test No. 3: freeing illegal address 0xdeadbeef." cr
  93   deadbeef free-mem
  94   dump-freelist
  95   ;
  96
  97 : testsuite ( -- )
  98   testsuite-init
  99   testsuite-test1
 100   testsuite-test2
 101   testsuite-test3
 102   ;
 103
 104 testsuite
 105
 106 bye