%constant %integer true=1,false=0,wordshift=2
%own %integer base=0,heap size=65535<<wordshift,
 moning=true,first hole=0,flag=0,
 first call=true
%record %format holef(%half %integer size,next)
%record %format crf(%integer conad,type,start,end)
%own %record (crf) connect report
%own %record (holef) %name prev,curr,succ
%constant %string (11) heap file="T#IHEAP"
%own %string (11) temp file=""
%system %routine %spec outfile(%string (31) file, %integer length,hole,prot,
    %integer %name conad,flag)
%external %integer %function %spec exist(%string (31) file)
%system %routine %spec destroy(%string (31) file, %integer %name flag)
%system %routine %spec connect(%string (31) file, %integer mode,hole,prot,
    %record (crf) %name report, %integer %name flag)
%system %routine %spec disconnect(%string (31) file, %integer %name flag)
%system %routine %spec newgen(%string (31) old,new, %integer %name flag)
%system %routine %spec rename(%string (31) old,new, %integer %name flag)
%system %routine %spec fill(%integer length,start,filler)
%external %integer %function %spec outpos
%external %integer %function %spec outstream
%system %string (31) %function %spec nexttemp
%system %string (31) %function %spec htos(%integer val,len)

%routine failed(%string (31) what, %string (255) msg)
   selectoutput(0)
   newline
   printstring("HEAP use: ".what." failed ".msg)
   newline
   printstring("        : first hole = ")
   write(first hole,1)
   newline
   %monitor
   %stop
%end

%routine OK(%string (31) what, %integer size,ad)
   %integer curstr
   %if moning # false %start
      curstr = outstream
      selectoutput(0)
      newline %if outpos # 0
      printstring("HEAP use: ".what)
      %unless size = 0 = ad %start
         %if outpos < 40 %then spaces(40 - outpos)
         printstring("   ".htos(size,8)." bytes    at ".htos(ad,8))
      %finish
      newline
      selectoutput(curstr)
   %finish
%end

%system %routine heapmon(%integer val)
   %if val = true %start
      moning = true
      OK("MONITOR on",0,0)
   %finish %else %start
      OK("MONITOR off",0,0)
      moning = false
   %finish
%end

%routine create heap
   %if exist(heap file) = false %start
      outfile(heap file,heap size,0,0,base,flag)
      %if flag # 0 %then failed("OUTFILE ".heap file,"")
   %finish %else %start
      destroy(heap file,flag)
      %if flag = 0 %then OK("DESTROY ".heap file,0,0) %else %c
         failed("DESTROY ".heap file,"")
      outfile(heap file,heap size,0,0,base,flag)
      %if flag # 0 %then failed("OUTFILE ".heap file,"")
   %finish
   curr == record(base)
   curr_size = heap size >> wordshift
   curr_next = 0
   first call = false
   OK("HEAP initialised",heap size,base)
%end

%external {TEMP!!!} %integer %function find hole(%integer size)
   %integer res
   first hole = first hole & X'0000FFFF'
   OK("Find hole :",0,first hole << wordshift + base)
   curr == record(first hole << wordshift + base)
   prev == record(addr(first hole))
   OK("SEARCH starts (?) at:",curr_size,addr(curr_size))
   %while curr_size < size %and curr_next # 0 %cycle
      OK("SEARCHING :",curr_size,addr(curr_size))
      prev == curr
      curr == record(base + curr_next << wordshift)
   %repeat
   %if curr_next = 0 %start
      OK("PREV==",integer(addr(prev_size)),addr(prev_size))
      OK("CURR==",integer(addr(curr_size)),addr(curr_size))
      %if curr_size < size %then failed("NEW","to find heap space")
      res = addr(curr_size)
      prev_next = (res - base + size) >> wordshift
      succ == record(res + size)
      succ_size = curr_size - size
      succ_next = 0
      OK("CLAIMED at top of heap",size,res)
      OK("        Next hole is :",succ_size,addr(succ_size))
      {!}first hole = (addr(succ_size) - base) >> wordshift %if res = base
      OK("PREV==",integer(addr(prev_size)),addr(prev_size))
      OK("CURR==",integer(addr(curr_size)),addr(curr_size))
      OK("SUCC==",integer(addr(succ_size)),addr(succ_size))
      %result = res
   %finish %else %start
      res = addr(curr_size)
      %if curr_size > size %start
         succ == record(res + size)
         succ_size = curr_size - size
         succ_next = curr_next
      %finish %else %start
         succ == record(curr_next << wordshift + base)
      %finish
      prev_next = (addr(succ_size) - base) >> wordshift
      OK("CLAIMED",size,res)
      {!}first hole = (addr(succ_size) - base) >> wordshift %if res = base
      %result = res
   %finish
%end

%integer %function my size of(%name info)
   %integer size
   size = size of(info)
   %if size // (1 << wordshift) # 0 %then %c
      %result = (size >> wordshift + 1) << wordshift
   %result = size
%end

%routine old try at new(%integer dr0,dr1)
   %if first call = true %then create heap
   dr0 = dr0 & X'FF'
   OK("NEW called",dr0,dr1)
   dr1 = find hole(dr0)
%end

%system %integer %function another try at  new(%name info)
   %integer dr0,dr1
   %if first call = true %then create heap
   dr0 = size of(info)
   dr1 = addr(info)
   OK("NEW called ",dr0,dr1)
   dr1 = find hole(dr0)
   OK("NEW tries to return",dr0,dr1)
   %result = dr1
%end

%routine make hole(%integer size,ad)
   first hole = first hole & X'0000FFFF'
   %unless base <= ad < heap size + base %and %c
      base <= ad + size <= heap size + base %start
      OK("ADDRESS ERROR - attempt to make hole outside heap",0,0)
      OK("Heap is :",heap size,base)
      OK("Hole wanted",size,ad)
      %return
   %finish
   curr == record(ad)
   fill(size,ad,0)
   curr_next = (ad - base) >> wordshift
   curr_size = size
   OK("New HOLE made ",size,ad)
   prev == record(addr(first hole))
   %if prev_next << wordshift + base > ad %start
      OK("New hole is below any other",0,0)
      curr_next = first hole
      first hole = (ad - base) >> wordshift
      %return {*****TEMP}
   %finish %else %start
      OK("Search for hole below starts",0,prev_next << wordshift + base)
      %while prev_next # 0 %and prev_next < curr_next %cycle
         prev == record(prev_next << wordshift + base)
         OK(".....to hole ",prev_size,addr(prev_size))
      %repeat
      curr_next = prev_next
      prev_next = (ad - base) >> wordshift
      OK("PREV==",integer(addr(prev_size)),addr(prev_size))
      OK("CURR==",integer(addr(curr_size)),addr(curr_size))
      %if addr(prev_size) + prev_size = ad %start
         OK("Merge with previous hole",0,0)
         prev_size = prev_size + curr_size
         prev_next = curr_next
         curr_size = 0
         curr_next = 0
         curr == prev
         OK("Resulting in",integer(addr(prev_size)),addr(prev_size))
      %finish
   %finish
   %if curr_next # 0 %start
      succ == record(curr_next << wordshift + base)
      %if addr(curr_size) + curr_next = addr(succ_size) %start
         OK("Merge with next hole at",succ_size,addr(succ_size))
         curr_size = curr_size + succ_size
         curr_next = succ_next
         succ_size = 0
         succ_next = 0
         OK("Resulting in",integer(addr(curr_size)),addr(curr_size))
      %finish
   %finish
%end


%system %routine dispose(%name info)
   %integer dr0,dr1
   dr0 = size of(info)
   dr1 = addr(info)
   OK("DISPOSE called",dr0,dr1)
   make hole(dr0,dr1)
   OK("DISPOSE completed",0,0)
%end

%system %routine heapfrag
   %integer holes,size,max,min,ave,curstr
   %if first call = true %then %c
      OK("HEAP FRAG called before NEW!",0,0) %and %return
   curstr = outstream
   selectoutput(0)
   newline %if outpos # 0
   printstring("HEAP use: FRAGMENTATION ANALYSIS")
   newline
   holes = 0
   size = 0
   min = heap size
   max = 0
   first hole = first hole & X'0000FFFF'
   curr == record(addr(first hole))
   printstring("offset of first hole is ".htos(curr_next << wordshift,
      8)." from base of ".heap file." at ".htos(base,8))
   newline
   %while curr_next # 0 %cycle
      curr == record(curr_next << wordshift + base)
      holes = holes + 1
      size = size + curr_size
      max = curr_size %if curr_size > max
      min = curr_size %if curr_size < min
      write(holes,5)
      write(curr_size,6)
      printstring(" ({X'".htos(curr_size,4)."'}")
      printstring("   X'".htos(addr(curr_size),8)."'")
      newline
   %repeat
   printstring("Total of ")
   write(size,1)
   printstring(" {X'".htos(size,8)."'} free bytes in ")
   write(holes,1)
   printstring(" holes")
   newline
   printstring("Largest hole is ")
   write(max,1)
   printstring(" {X'".htos(max,4)."'} bytes")
   newline
   printstring("Smalles hole is ")
   write(min,1)
   printstring(" {X'".htos(min,4)."'} bytes")
   newline
   ave = size // holes
   printstring("Average hole is ")
   write(ave,1)
   printstring(" {X'".htos(ave,4)."'} bytes")
   newline
   printstring("HEAP use : ANALYSIS COMPLETE")
   newline
   selectoutput(curstr)
%end

%system %integer %function new(%name info)
   %integer dr0,dr1
   %if first call = true %then create heap
   dr0 = size of(info)
   dr1 = addr(info)
   OK("NEW called :",dr0,dr1)
   dr1 = find hole(dr0)
   OK("NEW returns:",dr0,dr1)
   %result = dr1
%end

%end %of %file