Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | \ @(#) t_alloc.fth 97/01/28 1.4 |
2 | \ Test PForth ALLOCATE | |
3 | \ | |
4 | \ Copyright 1994 3DO, Phil Burk | |
5 | ||
6 | anew task-t_alloc.fth | |
7 | decimal | |
8 | ||
9 | 64 constant NUM_TAF_SLOTS | |
10 | ||
11 | variable TAF-MAX-ALLOC | |
12 | variable TAF-MAX-SLOT | |
13 | ||
14 | \ hold addresses and sizes | |
15 | NUM_TAF_SLOTS array TAF-ADDRESSES | |
16 | NUM_TAF_SLOTS array TAF-SIZES | |
17 | ||
18 | : TAF.MAX.ALLOC? { | numb addr ior maxb -- max } | |
19 | 0 -> maxb | |
20 | \ determine maximum amount we can allocate | |
21 | 1024 40 * -> numb | |
22 | BEGIN | |
23 | numb 0> | |
24 | WHILE | |
25 | numb allocate -> ior -> addr | |
26 | ior 0= | |
27 | IF \ success | |
28 | addr free abort" Free failed!" | |
29 | numb -> maxb | |
30 | 0 -> numb | |
31 | ELSE | |
32 | numb 1024 - -> numb | |
33 | THEN | |
34 | REPEAT | |
35 | maxb | |
36 | ; | |
37 | ||
38 | : TAF.INIT ( -- ) | |
39 | NUM_TAF_SLOTS 0 | |
40 | DO | |
41 | 0 i taf-addresses ! | |
42 | LOOP | |
43 | \ | |
44 | taf.max.alloc? ." Total Avail = " dup . cr | |
45 | dup taf-max-alloc ! | |
46 | NUM_TAF_SLOTS / taf-max-slot ! | |
47 | ; | |
48 | ||
49 | : TAF.ALLOC.SLOT { slotnum | addr size -- } | |
50 | \ allocate some RAM | |
51 | taf-max-slot @ 8 - | |
52 | choose 8 + | |
53 | dup allocate abort" Allocation failed!" | |
54 | -> addr | |
55 | -> size | |
56 | addr slotnum taf-addresses ! | |
57 | size slotnum taf-sizes ! | |
58 | \ | |
59 | \ paint RAM with slot number | |
60 | addr size slotnum fill | |
61 | ; | |
62 | ||
63 | : TAF.FREE.SLOT { slotnum | addr size -- } | |
64 | slotnum taf-addresses @ -> addr | |
65 | \ something allocated so check it and free it. | |
66 | slotnum taf-sizes @ 0 | |
67 | DO | |
68 | addr i + c@ slotnum - | |
69 | IF | |
70 | ." Error at " addr i + . | |
71 | ." , slot# " slotnum . cr | |
72 | abort | |
73 | THEN | |
74 | LOOP | |
75 | addr free abort" Free failed!" | |
76 | 0 slotnum taf-addresses ! | |
77 | ; | |
78 | ||
79 | : TAF.DO.SLOT { slotnum -- } | |
80 | slotnum taf-addresses @ 0= | |
81 | IF | |
82 | slotnum taf.alloc.slot | |
83 | ELSE | |
84 | slotnum taf.free.slot | |
85 | THEN | |
86 | ; | |
87 | ||
88 | : TAF.TERM | |
89 | NUM_TAF_SLOTS 0 | |
90 | DO | |
91 | i taf-addresses @ | |
92 | IF | |
93 | i taf.free.slot | |
94 | THEN | |
95 | LOOP | |
96 | \ | |
97 | taf.max.alloc? dup ." Final MAX = " . cr | |
98 | ." Original MAX = " taf-max-alloc @ dup . cr | |
99 | = IF ." Test PASSED." ELSE ." Test FAILED!" THEN cr | |
100 | ||
101 | ; | |
102 | ||
103 | : TAF.TEST ( NumTests -- ) | |
104 | 1 max | |
105 | dup . ." tests" cr \ flushemit | |
106 | taf.init | |
107 | ." Please wait for test to complete..." cr | |
108 | 0 | |
109 | DO NUM_TAF_SLOTS choose taf.do.slot | |
110 | LOOP | |
111 | taf.term | |
112 | ; | |
113 | ||
114 | .( Testing ALLOCATE and FREE) cr | |
115 | 10000 taf.test | |
116 |