git.gag.com Git - debian/pforth/blob - fth/t_alloc.fth

   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