fth/t_alloc.fth

\ @(#) t_alloc.fth 97/01/28 1.4
\ Test PForth ALLOCATE
\
\ Copyright 1994 3DO, Phil Burk

anew task-t_alloc.fth
decimal

64 constant NUM_TAF_SLOTS

variable TAF-MAX-ALLOC
variable TAF-MAX-SLOT

\ hold addresses and sizes
NUM_TAF_SLOTS array TAF-ADDRESSES
NUM_TAF_SLOTS array TAF-SIZES

: TAF.MAX.ALLOC? { | numb addr ior maxb -- max }
        0 -> maxb
\ determine maximum amount we can allocate
        1024 40 * -> numb
        BEGIN
                numb 0>
        WHILE
                numb allocate -> ior -> addr
                ior 0=
                IF  \ success
                        addr free abort" Free failed!"
                        numb -> maxb
                        0 -> numb
                ELSE
                        numb 1024 - -> numb
                THEN
        REPEAT
        maxb
;

: TAF.INIT  ( -- )
        NUM_TAF_SLOTS 0
        DO
                0 i taf-addresses !
        LOOP
\
        taf.max.alloc? ." Total Avail = " dup . cr
        dup taf-max-alloc !
        NUM_TAF_SLOTS / taf-max-slot !
;

: TAF.ALLOC.SLOT { slotnum | addr size -- }
\ allocate some RAM
        taf-max-slot @ 8 -
        choose 8 +
        dup allocate abort" Allocation failed!"
        -> addr
        -> size
        addr slotnum taf-addresses !
        size slotnum taf-sizes !
\
\ paint RAM with slot number
        addr size slotnum fill
;

: TAF.FREE.SLOT { slotnum | addr size -- }
        slotnum taf-addresses @  -> addr
\ something allocated so check it and free it.
        slotnum taf-sizes @  0
        DO
                addr i + c@  slotnum -
                IF
                        ." Error at " addr i + .
                        ." , slot# " slotnum . cr
                        abort
                THEN
        LOOP
        addr free abort" Free failed!"
        0 slotnum taf-addresses !
;

: TAF.DO.SLOT { slotnum  -- }
        slotnum taf-addresses @ 0=
        IF
                slotnum taf.alloc.slot
        ELSE
                slotnum taf.free.slot
        THEN
;

: TAF.TERM
        NUM_TAF_SLOTS 0
        DO
                i taf-addresses @
                IF
                        i taf.free.slot
                THEN
        LOOP
\
        taf.max.alloc? dup ." Final    MAX = " . cr
        ." Original MAX = " taf-max-alloc @ dup . cr
        = IF ." Test PASSED." ELSE ." Test FAILED!" THEN cr

;

: TAF.TEST ( NumTests -- )
        1 max
        dup . ." tests" cr \ flushemit
        taf.init
        ." Please wait for test to complete..." cr
        0
        DO  NUM_TAF_SLOTS choose taf.do.slot
        LOOP
        taf.term
;

.( Testing ALLOCATE and FREE) cr
10000 taf.test