Category : Forth Source Code
Archive   : FLISP.ZIP
Filename : LHEAP.SEQ

comment: HEAP sequential file source code
F-PC 3.xx
Opened March 23 89
Adapted from Dick Pountain by Kenneth O'Heskin
comment;



: (S [COMPILE] ( ; IMMEDIATE
: (P [COMPILE] ( ; IMMEDIATE
: ENDIF [COMPILE] THEN ; IMMEDIATE \ not in ver 3.xx for some strange
\ reason

\ D.P. likes the following for comments; it looks good because it
\ is analogous to stack effects dashes. Here it is defined as
\ a straight synonym of "\"

\ : -- ( -- stop interpretation/compilation for the rest of the line )
\ SPAN @ >IN ! ; IMMEDIATE

\ oops! fpc 3. needs a different one
: -- #tib @ >in ! ; immediate



\ -------- Dos Memory Functions ------------

( ** ) \ 0 VALUE HPSEG
0 VALUE HSEGSIZE
10240 CONSTANT HEAPSIZE ( ** ) \ size of heap in bytes
HEAPSIZE paragraph =: HSEGSIZE \ size of heap in clicks
DEFER DO-OTHER ' NOOP IS DO-OTHER \ define your own panic button
\ for memory allocation failure

: (dother) Abort" Memory allocation error" ;
' (dother) is do-other


\ 16 bytes is a Click, Intel segments are measured in clicks
: CLK>BYTE ( n,clicks -- u,#bytes ) 16 UM* DROP ; \ carefull with
\ : BYTE>CLK ( #bytes -- n,clicks ) 16 MU/MOD NIP ; \ these
' paragraph alias BYTE>CLK

hidden clearmem forth ( **a ds )

comment: ( ** )
: REQUEST-HEAPSEG
hsegsize ALLOC 0=
IF =: HPSEG
CLK>BYTE .
." byte Heap Segment Allocated" CR ( ** )
ELSE DO-OTHER \ alternative course of action
THEN ;

\ ( ** ds ) REQUEST-HEAPSEG
comment; ( ** )

heapsize 0 pointer hpseg ( **a )

: HZFIL HPSEG 0 HEAPSIZE 0 LFILL ;
HZFIL



\ -------------------- The Heap --------------------------

0 CONSTANT ZERO
HPSEG HEAPSIZE 2CONSTANT ENDHEAP> \ top of the heap area
HPSEG 0 2CONSTANT HEAP \ create the heap

: >HEAP ( n-index, -- ) HEAP ROT + ;


\ it is clear that an additional level of indirection will have to be added
\ to cover for the segment offsets; HEAP must be a single length addr to
\ stick into HEAP.PTR

VARIABLE HEAP.PTR \ heap pointer
VARIABLE HANDLE.PTR \ handles pointer
VARIABLE FREE.HANDLE \ Free list pointer

-- very drastic make sure you mean it!
: HEAP-RESET HZFIL \ init to zeroes
HEAP NIP HEAP.PTR ! \ reset all pointers
ENDHEAP> NIP 2- HANDLE.PTR !
ZERO FREE.HANDLE ! ;

HEAP-RESET

comment:
\ Some test words
: HIDUMP ( -- dump heap contents to screen )
HEAPSIZE 0 DO HPSEG I C@L EMIT LOOP ; \ dump the whole thing

: HPD ( -- dump heap contents to screen )
0 HEAPSIZE DO HPSEG I C@L EMIT -1 +LOOP ;
-- this is the reverse of Hidump and accurately reflects
-- the architecture of the Heap, with the handles on
-- top and the heap body growing from the bottom
comment;


: HEAP> HPSEG HEAP.PTR @ ; \ fetch heap pointer
: +HEAP> ( n -- ) HEAP.PTR +! ; \ advance heap pointer

: HANDLE> HPSEG HANDLE.PTR @ ; \ fetch handle pointer
: +HANDLE> ( n -- ) HANDLE.PTR +! ; \ advance handle pointer


: H+! ( n, addr -- ) DUP HPSEG SWAP @L ROT + HPSEG ROT !L ;

\ adjust by n the contents of handles which point to objects above addr
: ADJUST.HANDLES ( n addr -- )
SWAP NEGATE
HEAPSIZE HANDLE.PTR @ 2+ \ range of handle spaces
DO HPSEG I @L 2 PICK > \ see below
HANDLE.PTR @ HPSEG I @L - 0> AND
IF I OVER SWAP H+! ENDIF
2 +LOOP 2DROP ;



-- Adjust.handles performs a run through the whole of the handle table
-- (betwe-en addresses Endheap> and Handle> ) looking for handles which point
-- to objects that have addresses higher than that of the newly removed
-- object. It also has to reject all handles which are not in current use.
-- This it can do because they are linked together into a free list; in other
-- words they contain either zero or an address which lies within the handle-
-- table itself (ie: is greater than HANDLE> ). Those handles which are
-- selected are adjusted by a fixed offset which is simply the distance that
-- the Heap was moved to compact it.

\ return a new or second-hand handle
: GET.HANDLE ( -- n,hdl ) \ 'hdl' is a 16 bit number
FREE.HANDLE @ ?DUP 0=
IF HANDLE> NIP -2 +HANDLE> \ make new handle
ELSE DUP
( ** ) hpseg swap @L
FREE.HANDLE ! \ reuse old handle
ENDIF ;


defer ?full ' noop is ?full
defer ?neg ' noop is ?neg


32768 heapsize >
#if \ compile if heap smaller than 32k

\ will handle table collide with heap if 'size' bytes are allocated?
: (?FULL) ( size -- size )

DUP HANDLE.PTR @ HEAP.PTR @ ROT + 2+ - 0<
IF ." No more heap space" CR ABORT ENDIF ;

-- ?FULL checks for legal parameters, and causes an abort if fail. This is
-- too brutal for a running application, in which case HALLOC should return
-- a false flag instead of a handle should there be a failure due to lack
-- of space. The appl. could test the flag and query the user as to what
-- to do about it, or set about garbage collection to free up memory.

-- ?NEG however, must cause a halt in programme flow (if not an actual
-- Forth abort), since a negative allocation will irretrievably corrupt the
-- heap

: (?NEG) ( size -- size )
DUP 0< IF ." Negative allocation" CR ABORT ENDIF ;

' (?neg) is ?neg
' (?full) is ?full

#endif


-- allocate space on the heap for an object
: HALLOC ( size -- hdl or 0 )
?NEG ?FULL \
GET.HANDLE \ get a handle
HEAP> 2+ 2 PICK ROT SWAP !L \ put pointer in handle
OVER HEAP> !L \ put size in object
SWAP 2+ +HEAP> ; \ bump heap pointer

: SIZE? ( hdl -- size ) \ get size of object
HPSEG SWAP @L 2- HPSEG SWAP @L ;


-- return a handle to the free list
: RELEASE.HANDLE ( hdl -- )
FREE.HANDLE @ OVER HPSEG SWAP !L
FREE.HANDLE ! ;


-- reclaim the memory occupied by an object
: HFREE ( hnd -- )
DUP SIZE? 2+
OVER HPSEG SWAP @L 2- \ source for move
2DUP + DUP >R \ destination for move
SWAP HPSEG ROT OVER 3 ROLL
HEAP.PTR @ R@ - CMOVEL \ compact heap
DUP NEGATE +HEAP> \ adjust heap pointer
SWAP RELEASE.HANDLE \ free the handle
R> ADJUST.HANDLES ; \ adjust handles



comment: example usage: VARIABLE FRED
25 HALLOC FRED !
Fred now contains a handle to a newly allocated 25 piece of
heap space. The size of this piece can be found by FRED @ SIZE?
and its address by FRED @ @.

It is important to remember that if the handle is lost then that
object can never be accessed again and its memory cannot be
reclaimed. The handle can be lost easily; for example
16 HALLOC FRED ! --Fred now contains a new handle
and the old one is irretrievably lost. What we should have done
is release the old object before assigning anything new to FRED,
as per FRED @ HFREE 16 HALLOC FRED !

Another important thing is to remember that the whole heap can
quite easily be corrupted by performing illegal operations on
handles. For example, storing a value directly into a handle
is disastrous, as also is trying to use a handle which has been
released. After FRED @ HFREE, FRED still contains the address
of the freed handle, which could be misused. FRED should be
reinitialised to zero after a HFREE unless new memory is reassigned
to it immediately.

comment;

comment:
\ Some custom heap object defining words
: heapvar: ( -- 2-byte datatype ) create 2 allot
does> @ ;

-- This works fine; needs initialisation with INIT, as in
-- HEAPVAR: TOM TOM INIT

\ Create a cell array in heap memory with a handle
: harray: ( n,size -- ) create 0 halloc hfree 2* halloc ,
does>
@ HPSEG dup rot @l rot 2* + ;

-- handle automatically assigned; use as in
-- 100 HARRAY JOE 10 JOE @L or 8283 89 JOE !L
-- WARNING: You have to be very carefull about using a datatype
-- like this, and not to confuse its properties with others kinds
-- of arrays which exist in other memory segs, and perform
-- different kinds of tasks. However, for all that, it works.

\ create a byte array in heap memory
: charray: ( n,size -- )
create 0 halloc hfree halloc ,
does>
@ HPSEG dup rot @l rot + ;
comment;
\ comment out the appropriate word
comment:
: fharray: ( n,number of fp elements -- ) \ for 8 byte floating point
create 0 halloc hfree 8* halloc , \ numbers -- Smith's SFLOAT.SEQ
does> \ and HFLOAT.SEQ
@ HPSEG dup rot @l rot 8* + ;
comment;
comment:
: fharray: ( n,number of fp elements -- ) \ for 10 byte floating point
create 0 halloc hfree 10 * halloc , \ numbers -- VP Planner fp
does>
@ HPSEG dup rot @l rot 10 * + ;

comment;
: INIT 0 HALLOC SWAP ! ; -- create a new handle
: << DUP -ROT @ HFREE HALLOC SWAP ! ; -- allocate a piece
: >> @ @ ; -- get addr of piece
: <
\ use: HEAPVAR: FRED
\ FRED INIT
\ 25 FRED << -- assign 25 bytes of space to Fred
\ FRED >> -- put addr of this space on stack
\ 50 FRED << -- double the space allocated to Fred
\ <

\ Working example: dynamic string storage using a heap
-- Forth uses both packed strings (addr of a string whose first
-- byte contains a char count).

-- And unpacked strings (the addr of the first char and count)

-- WORD returns address of a packed string but TYPE wants an unpacked
-- string argument, so COUNT must be used to convert one to t'other

\ basic word for placing strings on heap is $>HEAP which takes an unpacked
\ string argument and returns a handle
comment: ( ** )
: $>heap ( addr count -- hdl )
dup halloc dup >r HPSEG swap @l
rot ?cs: swap rot HPSEG swap 4 roll
cmovel r> ; -- copy string

-- This version assumes the string is originating in the current
-- segment and is going to the heap segment

-- the word works very simply by allocating a piece of heap
-- memory and then using cmove to copy the string into it; the
-- count is not copied as the heap already supplies one


\ Special definition of "

: h" ( +++ hdl ) ascii " word count $>heap
state @ if [compile] literal endif ; immediate

: in$ ( +++ hdl ) bl word count $>heap ; -- we can also write an expect
-- word

-- use: HEAPVAR: FRED$ FRED$ INIT
-- h" Mississippi " FRED$ ! or
-- : NEWFRED FRED$ @ HFREE IN$ FRED$ ! ; NEWFRED Blueblazes
-- note: Fred$ does not contain a string, but a handle!
comment;
\ turns a handle into an unpacked string
: >$ ( hdl -- seg adr count )
HPSEG swap 2dup @l swap size? ;

comment:
\ string formatters
: xtype (s segment,offset,n --- )
bounds ?do dup i c@l emit loop drop ;

: h$. ( hdl -- display ) >$ xtype ;
-- H$. types directly from HPSEG memory; slow as icewater! but useful
-- for testing

: st. >$ dup >r ?cs: pad rot cmovel pad r> type ;
-- decently fast; use: FRED$ @ st.
comment;
-- There is endless scope for playing with the syntax of string
-- manipulation in this way, but one should always keep in mind
-- the goals of consistency and security rather than mere pretti-
-- fication. In the above examples, both string literals and
-- variables return the SAME type of object, namely a handle.
-- Avoiding mixed representations helps forestall programming errors.

comment:
\ One handy string manipulation word is one that concatenates two strings
\ it is normally called $+ which takes the handles of two strings as
\ arguments and return a handle to anew string formed by joining them. Here
\ is a definition:


: h$+ ( hdl1 hdl2 -- hdl3 ) swap 2dup
size? swap size? + halloc
rot >$ dup >r HPSEG 4 pick @l HPSEG swap rot cmovel \ mov 2nd str
swap >$ HPSEG 4 pick @l HPSEG swap rot r> + cmovel ; \ mov 1st str
-- This one lops off the last two chars of the second string and
-- leaves in its old handle.
comment;


\ test (although it requires the direct manipulation of handles again!)
comment: VARIABLE A$ VARIABLE B$ VARIABLE C$
A$ INIT " MATTER" A$ !
B$ INIT " HORN" B$ !
C$ INIT A$ @ B$ @ S+ C$ !
C$ @ $. MATTERHORN ok
comment;
-- it must be stressed that operators similar to Heapvar: >> etc. be
-- defined; we should not be concerned with handles at all at this level


\ resize operations
-- The object here is to change the size of a piece of memory without
-- affecting its contents. Some important arrays need to be resized
-- during runtime, such as buffers to hold the contents of files of
-- different sizes. We could CMOVEL it around hither and yon but that
-- is a bit inflexible and time burning.
-- DP's solution is simply to move it to the top of the heap, claim the
-- original space with a HFREE operation and adjust the pointers accordingly.
-- If the same structure must be resized several times, then after the first
-- it is only a matter of adjusting the pointers each time.



: RESIZE ( hdl size -- )
?NEG OVER HPSEG SWAP @L 2- -- get addr of size field
2DUP HPSEG SWAP @L - 2- -- calculate size change
?FULL DROP -- enough room?
DUP DUP HPSEG SWAP @L + 2+ HEAP> NIP = -- is it top of heap?
IF 2DUP HPSEG SWAP @L - +HEAP> -- adjust heap pointer
HPSEG SWAP !L DROP -- store new size
ELSE HPSEG SWAP HEAP> 3 PICK 3 PICK @L
2+ CMOVEL -- else copy to heap top
HALLOC SWAP HFREE -- allocate new space, free old
DUP HPSEG SWAP @L
GET.HANDLE HPSEG SWAP !L -- restore original..
RELEASE.HANDLE -- ..handle
ENDIF ;

-- use: fred @ 100 resize


comment:

\ zap -- free heap space occupied by redundant objects

: ZAP ' >BODY @ ( ** ) -- get object's pfa
DUP HFREE -- free its heap space
0 SWAP
( ** ) hpseg -rot !L ; -- scrub handle too, for luck

\ use: ZAP FRED
\ this is a brute force zapper; don't try to use a word once it
\ has been zapped, because it is still in the dictionary; its
\ handle and pfa point to nothing, but ops like HFREE SIZE? etc.
\ will crash; however the point is proven; once a redundant datatype
\ is no longer wanted, it can be wasted and the heap space freed up.
comment;