1 \ this is the memory management testsuite.
3 \ run it with paflof < memory-testsuite.fs 2>/dev/null
7 \ dumps all free-list entries
8 \ useful for debugging.
10 : dump-freelist ( -- )
11 ." Dumping freelist:" cr
14 \ If the free list is empty we notify the user.
15 dup 0= if ." empty." drop cr exit then
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
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.
31 : testsuite-init ( -- )
32 here 40000 cell+ dup allot ( -- ptr len )
35 ." start-mem = 0x" start-mem @ . cr
36 ." end-mem = 0x" end-mem @ . cr
37 ." free-list = 0x" free-list @ . cr
39 ." Memory management initialized." cr
43 : testsuite-test1 ( -- )
44 ." Test No. 1: Allocating all available memory (256k)" cr
48 ." worked, ptr=0x" dup .
55 ." Freeing memory." cr
61 : testsuite-test2 ( -- )
62 ." Test No. 2: Allocating 5 blocks" cr
69 ." Allocated 5 blocks. Stack:" cr .s cr
73 ." Freeing Block 2" cr
74 3 pick free-mem dump-freelist
76 ." Freeing Block 4" cr
77 over free-mem dump-freelist
79 ." Freeing Block 3" cr
80 2 pick free-mem dump-freelist
82 ." Cleaning up blocks 1 and 5" cr
83 free-mem \ Freeing block 5
85 3drop \ blocks 4, 3, 2
91 : testsuite-test3 ( -- )
92 ." Test No. 3: freeing illegal address 0xdeadbeef." cr