-\ @(#) t_alloc.fth 97/01/28 1.4\r
-\ Test PForth ALLOCATE\r
-\\r
-\ Copyright 1994 3DO, Phil Burk\r
-\r
-anew task-t_alloc.fth\r
-decimal\r
-\r
-64 constant NUM_TAF_SLOTS\r
-\r
-variable TAF-MAX-ALLOC\r
-variable TAF-MAX-SLOT\r
-\r
-\ hold addresses and sizes\r
-NUM_TAF_SLOTS array TAF-ADDRESSES\r
-NUM_TAF_SLOTS array TAF-SIZES\r
-\r
-: TAF.MAX.ALLOC? { | numb addr ior maxb -- max }\r
- 0 -> maxb\r
-\ determine maximum amount we can allocate\r
- 1024 40 * -> numb\r
- BEGIN\r
- numb 0>\r
- WHILE\r
- numb allocate -> ior -> addr\r
- ior 0=\r
- IF \ success\r
- addr free abort" Free failed!"\r
- numb -> maxb\r
- 0 -> numb\r
- ELSE\r
- numb 1024 - -> numb\r
- THEN\r
- REPEAT\r
- maxb\r
-;\r
-\r
-: TAF.INIT ( -- )\r
- NUM_TAF_SLOTS 0\r
- DO\r
- 0 i taf-addresses !\r
- LOOP\r
-\\r
- taf.max.alloc? ." Total Avail = " dup . cr\r
- dup taf-max-alloc !\r
- NUM_TAF_SLOTS / taf-max-slot !\r
-;\r
-\r
-: TAF.ALLOC.SLOT { slotnum | addr size -- }\r
-\ allocate some RAM\r
- taf-max-slot @ 8 -\r
- choose 8 + \r
- dup allocate abort" Allocation failed!"\r
- -> addr\r
- -> size\r
- addr slotnum taf-addresses !\r
- size slotnum taf-sizes !\r
-\\r
-\ paint RAM with slot number\r
- addr size slotnum fill\r
-;\r
-\r
-: TAF.FREE.SLOT { slotnum | addr size -- }\r
- slotnum taf-addresses @ -> addr\r
-\ something allocated so check it and free it.\r
- slotnum taf-sizes @ 0\r
- DO\r
- addr i + c@ slotnum -\r
- IF\r
- ." Error at " addr i + .\r
- ." , slot# " slotnum . cr\r
- abort\r
- THEN\r
- LOOP\r
- addr free abort" Free failed!"\r
- 0 slotnum taf-addresses !\r
-;\r
-\r
-: TAF.DO.SLOT { slotnum -- }\r
- slotnum taf-addresses @ 0=\r
- IF\r
- slotnum taf.alloc.slot\r
- ELSE\r
- slotnum taf.free.slot\r
- THEN\r
-;\r
-\r
-: TAF.TERM\r
- NUM_TAF_SLOTS 0\r
- DO\r
- i taf-addresses @\r
- IF\r
- i taf.free.slot\r
- THEN\r
- LOOP\r
-\\r
- taf.max.alloc? dup ." Final MAX = " . cr\r
- ." Original MAX = " taf-max-alloc @ dup . cr\r
- = IF ." Test PASSED." ELSE ." Test FAILED!" THEN cr\r
- \r
-;\r
-\r
-: TAF.TEST ( NumTests -- )\r
- 1 max\r
- dup . ." tests" cr \ flushemit\r
- taf.init\r
- ." Please wait for test to complete..." cr\r
- 0\r
- DO NUM_TAF_SLOTS choose taf.do.slot\r
- LOOP\r
- taf.term\r
-;\r
-\r
-.( Testing ALLOCATE and FREE) cr\r
-10000 taf.test\r
-\r
+\ @(#) 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
+
projects / pforth / blobdiff