! Heap package for old system,
! adapted from version for new system
! RWT May 1984

%owninteger heap=0,increment=2048+4

@16_1138 %integerfn getvm(%integer bytes)

%externalintegerfn heapget(%integer need)
%integer block,pos,size
  %signal 5,0,need{,"Illegal heap request"} %if need<=0
  need = (need+7)&\3
  block = heap
  %cycle
    %if block=0 %start
      size = need; size = increment %if size<increment
      size = size+8
      block = getvm(size)
      integer(block) = heap
      heap = block
      integer(block+size-4) = 0
      integer(block+4) = size-8
    %finish
    pos = block+4
    %cycle
      size = integer(pos); %exitif size=0
      %if size<0 %then pos = pos-size %elsestart
        %while integer(pos+size)>0 %cycle
          size = size+integer(pos+size)
        %repeat
        integer(pos) = size
        %if size>=need %start
          size = size-need; integer(pos) = size; pos = pos+size
          integer(pos) = -need; pos = pos+4
{Un-assign}
{}need = need>>2-2 {-1 for +7 above, -1 for dbra}
{}*move.l pos,a0
{}*move.l need,d0
{}loop: *move.l d7,(a0)+
{}*dbra d0,loop
          *move.l pos,a0; %result = pos
        %finish
        pos = pos+size
      %finish
    %repeat
    block = integer(block)
  %repeat
%end

%routine locate(%integer target)
%integer chunk,pos,dif
  %signal 5,0,target+4 %if target<=0
  chunk = heap
  %while chunk#0 %cycle
    %signal 5,1,chunk %if chunk<=0 %or chunk&3#0
    pos = chunk+4
    %cycle
      target = 0 %if pos=target
      %signal 5,1,pos %if pos<=0 %or pos&3#0
      dif = integer(pos)
      %exitif dif=0
      pos = pos+|dif|
    %repeat
    chunk = integer(chunk)
  %repeat
  %signal 5,0,target+4 %unless target=0
%end

%externalroutine heapput(%integer pos)
  %signal 5,0,pos %if pos<=0
  pos = pos-4
  locate(pos)
  %signal 5,0,pos+4{,"Heap corrupt"} %unless integer(pos)<0
  integer(pos) = -integer(pos)
%end

%externalroutine heapinit(%integer size)
  size = (size+3)&\3
  size = 2048 %if size<2048
  increment = size+4
  heap = 0
  heapput(heapget(1))
%end

%externalroutine heapanal
%integer chunks=0,u,f
  %integerfn scan(%integer sign)
  %integer min=0,max=0,num=0,total=0
  %integer block,pos,size,xor
    block = heap
    %while block#0 %cycle
      pos = block+4; chunks = chunks+1
      %cycle
        size = integer(pos); %exitif size=0
        xor = size!!sign
        size = |size|
        %if xor>=0 %start
          size = size-4
            num = num+1; total = total+size
            min = size %if min=0 %or size<min
            max = size %if size>max
          size = size+4
        %finish
        pos = pos+size
      %repeat
      block = integer(block)
    %repeat
    write(num,1); printstring(" items, smallest")
    write(min,1); printstring(", largest")
    write(max,1); printstring(", total")
    write(total,1); printstring(" bytes"); newline
    %result = total+4*num
  %end
  printstring("Used:"); u = scan(-1)
  printstring("Free:"); f = scan(1)
  printstring("Spread over"); write(chunks>>1,1)
  printstring(" segments occupying"); write(u+f+chunks*4,1)
  printstring(" bytes"); newline
%end

%externalintegerfn freestore
  *move.l sp,d0
  *sub.l d6,d0
%end

%externalrecord(*)%map new(%name n{passed as D0=size})
  *bsr heapget; *move.l d0,a0
%end

%externalroutine dispose(%name n{passed as A0=address})
  *move.l a0,d0; *bsr heapput
%end

%endoffile