\ 4tH library - ANS MEMORY - Copyright 2004 J.L. Bezemer
\ You can redistribute this file and/or modify it under
\ the terms of the GNU General Public License

[UNDEFINED] allocate [IF]
[UNDEFINED] /heap [IF]
64 constant /heap
[THEN]

[UNDEFINED] #heap [IF]
256 constant #heap
[THEN]

#heap array HAT
#heap /heap [*] string heap
                                       \ set HAT to zero
:noname #heap 0 do 0 HAT i th ! loop ; execute
                                       \ calculate addresses
: HAT# cells HAT + ;                   ( n -- h#)
: addr>HAT heap - /heap / dup 0< 0= over #heap < and ;
                                       ( a -- h# f)
: freespace?                           ( #b n -- #b n f f)
  over over + over true -rot           \ set up loop parameters
  do i HAT# @ 0<> if 0= leave then loop dup
;                                      \ check all blocks, DUP flag
                                       \ allocate space on heap
: allocate                             ( n -- a f)
  dup #heap /heap [*] 1 [+] < swap
  /heap -1 [+] + /heap / dup 0> rot and  
  if                                   \ is request within limits? 
    #heap 1 [+] over - dup dup 0       \ is there enough free space?
    do drop drop i freespace? if leave then loop
    over /heap * chars heap + swap     \ if so, update HAT and exit
    if -rot tuck + swap do dup i HAT# ! loop false exit                       
    else drop drop                     \ else drop values
    then
  then true                            \ and signal error
;
                                       \ free space on heap
: free                                 ( a -- f)
  true over addr>HAT                   \ convert address
  if                                   \ if within limits
    #heap swap do                      \ check contents of HAT
      over i HAT# tuck @ =             \ if allocated space
      if 0 swap ! drop false else drop leave then
    loop                               \ then update HAT else quit
  else drop                            \ clean up stack
  then nip
;
                                       \ return allocated memory size
: allocated                            ( a -- n)
  dup addr>HAT                         \ convert address
  if                                   \ if a valid address
    tuck begin                         \ save the offset
      over over HAT# @ = dup >r        \ is it a real address?
      if 1+ then                       \ increase count
      dup #heap = r> 0= or             \ limit has been reached?
    until
  else drop drop 0 dup dup             \ discard garbage
  then nip swap - /heap *              \ calculate size in bytes
;
                                       \ resize an allocated memory block
: resize                               ( a1 n1 -- a2 f)
  over swap                            ( a1 a1 n1)
  over allocated                       ( a1 a1 n1 n2)
  over allocate                        ( a1 a1 n1 n2 a2 f)
  if                                   ( a1 a1 n1 n2 a2)
    drop drop drop drop true           ( a1 f)
  else                                 ( a1 a1 n1 n2 a2)
    >r min r@ swap cmove               ( a1)
    free drop r> false                 ( a2 -f)
  then
;

[DEFINED] debug-mem [IF]
: .HAT #heap 0 do i dup . HAT# ? cr loop ;
[THEN]

[DEFINED] 4TH# [IF]
hide HAT
hide heap
hide HAT#
hide addr>HAT
hide freespace?
[THEN]
[THEN]