/fth/t_alloc.fth
Forth | 116 lines | 102 code | 14 blank | 0 comment | 1 complexity | b976cc3d5514556dce7a57ba41b8cc47 MD5 | raw file
- \ @(#) 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
-