[pforth] / 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
Commit	Line	Data
8e9db35f PB	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