%include "itrimp_hostcodes"
%constinteger host=IBMXA
%constinteger target=vax
%constinteger wordad=0
%externalintegermapspec comreg %ALIAS "S#COMREGMAP"(%integer n)
%routinespec phex%alias "S#PHEX"(%integer n)
%externalintegerfnspec getspace(%integer sizeinbytes)

%recordformat heapfm(%integer link,id,item1,item2)
%constinteger endoflist=0
%owninteger mon=0,free,heapinc,heapad,numels,tot=0

%routine format heap(%integer ad)
%record(heapfm) %arrayformat heapafm(1:100000)
%record(heapfm) %arrayname heap

%integer i

  heap == array(ad,heapafm)
  free = ad
  heap(i)_link=addr(heap(i+1)) %for i=1,1,numels-1
%end

%routine extend heap
  %integer flag,fromad

  fromad=getspace(heapinc)<<wordad
  format heap(fromad)
%end

%externalroutine heapmon
  mon=1
%end

%externalroutine initialise heap
  %integer flag
  %record(heapfm) h
  mon=comreg(26)>>8
  heapinc=4096-8
  numels=heapinc//16
  heapad=getspace(heapinc)<<wordad
  format heap(heapad)
%end

%externalroutine free heap list(%integername listhead)
  %integer l
  %record(heapfm) %name h

  l = listhead
  %while l#endoflist %cycle
    h== record(l)
    l=h_link
    h_link=free
    free=addr(h)
    tot=tot-1
  %repeat
  listhead=0
%end

%externalroutine put on heap(%integer id,item1,%integername start)
  %record(heapfm) %name h

  %if free=endoflist %then extendheap
  h==record(free)
  free=h_link
  h_id=id
  h_item1=item1
  h_link=start
  tot=tot+1
  start=addr(h)
%end

%externalroutine put2 on heap(%integer id,item1,item2,%integername start)
  %record(heapfm) %name h

  %if free =endoflist %then extendheap
  h==record(free)
  free=h_link
  h_id=id
  h_item1=item1
  h_item2=item2
  h_link=start
  tot=tot+1
  start=addr(h)
%end

%externalintegerfn Find and remove from heap(%integer id,%integername start)
%record(heapfm) %name prev,h
%integer fndad

h==record(start)
prev==record(endoflist)
%while addr(h)#endoflist %cycle
  %if h_id=id %start
    fndad=addr(h)
    %if start=fndad %then start=h_link %else prev_link=h_link
    h_link=free
    free=fndad
    tot=tot-1
    %result=fndad
  %finish
  prev=h
  h==record(h_link)
%repeat
%result=0
%end

%externalintegerfn find on heap(%integer id, %integername start)
%record(heapfm) %name H

h==record(start)
%while addr(h)#endoflist %cycle
 %if h_id=id %then %result=addr(h)
  h==record(h_link)
%repeat
%result=0
%end
%endoffile