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

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