blob: 9dace5117c66cfa0d3fd77e93f743b56be4eaa9a (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
\ 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
|
