| 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 | |