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