git.gag.com Git - debian/pforth/blob - 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 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