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
107
108
109
110
111
112
113
114
115
116
|
\ @(#) t_alloc.fth 97/01/28 1.4
\ Test PForth ALLOCATE
\
\ Copyright 1994 3DO, Phil Burk
anew task-t_alloc.fth
decimal
64 constant NUM_TAF_SLOTS
variable TAF-MAX-ALLOC
variable TAF-MAX-SLOT
\ hold addresses and sizes
NUM_TAF_SLOTS array TAF-ADDRESSES
NUM_TAF_SLOTS array TAF-SIZES
: TAF.MAX.ALLOC? { | numb addr ior maxb -- max }
0 -> maxb
\ determine maximum amount we can allocate
1024 40 * -> numb
BEGIN
numb 0>
WHILE
numb allocate -> ior -> addr
ior 0=
IF \ success
addr free abort" Free failed!"
numb -> maxb
0 -> numb
ELSE
numb 1024 - -> numb
THEN
REPEAT
maxb
;
: TAF.INIT ( -- )
NUM_TAF_SLOTS 0
DO
0 i taf-addresses !
LOOP
\
taf.max.alloc? ." Total Avail = " dup . cr
dup taf-max-alloc !
NUM_TAF_SLOTS / taf-max-slot !
;
: TAF.ALLOC.SLOT { slotnum | addr size -- }
\ allocate some RAM
taf-max-slot @ 8 -
choose 8 +
dup allocate abort" Allocation failed!"
-> addr
-> size
addr slotnum taf-addresses !
size slotnum taf-sizes !
\
\ paint RAM with slot number
addr size slotnum fill
;
: TAF.FREE.SLOT { slotnum | addr size -- }
slotnum taf-addresses @ -> addr
\ something allocated so check it and free it.
slotnum taf-sizes @ 0
DO
addr i + c@ slotnum -
IF
." Error at " addr i + .
." , slot# " slotnum . cr
abort
THEN
LOOP
addr free abort" Free failed!"
0 slotnum taf-addresses !
;
: TAF.DO.SLOT { slotnum -- }
slotnum taf-addresses @ 0=
IF
slotnum taf.alloc.slot
ELSE
slotnum taf.free.slot
THEN
;
: TAF.TERM
NUM_TAF_SLOTS 0
DO
i taf-addresses @
IF
i taf.free.slot
THEN
LOOP
\
taf.max.alloc? dup ." Final MAX = " . cr
." Original MAX = " taf-max-alloc @ dup . cr
= IF ." Test PASSED." ELSE ." Test FAILED!" THEN cr
;
: TAF.TEST ( NumTests -- )
1 max
dup . ." tests" cr \ flushemit
taf.init
." Please wait for test to complete..." cr
0
DO NUM_TAF_SLOTS choose taf.do.slot
LOOP
taf.term
;
.( Testing ALLOCATE and FREE) cr
10000 taf.test
|
