{Program to statically apply relocation information to locations in GLA}
{Particularly for standalone programs such as spoolers, test programs etc}

%option  "noopen"
%begin
   %include "sysinc:parmfm.inc"
   %include "sysinc:command.inc"

   {Dirty assumptions}
   %recordformat  hdfm(%short  base,n)
   %recordformat  headfm(%short pure size, gla size, code disp, lit disp,
                                registers, mainep,
                         %record(hdfm) reloc, defs, specs, ldiag, vdiag)

   %owninteger    CODE SEG = 15,
                   GLA SEG = 14,
                  CODE OFFSET = x'10'

   %string(31)    root name = COMMAND_in1


   {DA i/o support}
   %owninteger  DA KEY = 0
   %owninteger  CURRENT BLOCK = -1, DIRTY = 0
   %integer     gla start   {so CODE OFFSET can be allowed for automatically}
   %byteintegerarray  block(0:511)
   %constinteger da read = 9,  da write = 10
   %routine  OPEN DA(%string(31)  fd)
      %record(parmfm)  p
      string(addr(p_sact)) = fd;  svc(17,p)      {pack fd}
      %if p_p2 < 0 %start
         print string(fd." ??".SNL)
         %stop
      %finish
      p_p5 = -1   {permit write but not auto-extend}
      p_dact = 6;  svc(20,p);   {open da}
      DA KEY = p_p5
      %if p_p6 < 0 %start
         print string("Open da: ".fd."  ".string(addr(p_p1)).SNL )
         %stop
      %finish
   %end
   %routinespec  write da(%integer  block no)
   %routine  CLOSE DA
      %record(parmfm)  p
      write da(current block) %if dirty # 0
      current block = -1
      p_p5 = DA KEY
      p_dact = 11; svc(20,p)
      DA KEY = 0
      %if p_p6 < 0 %start
         print string("Close da: ".string(addr(p_p1)).SNL )
         %stop
      %finish
   %end
   %routine  READ DA(%integer  block no)
      %record(parmfm)  p
      p_p4 = addr(block(0))
      p_p5 = DA KEY
      p_p6 = blockno
      p_dact = da read;  svc(20,p)
      %if p_p6 < 0 %start
         print string("DA read: ".string(addr(p_p1)).SNL )
         %signal 15,15
      %finish
   %end
   %routine  WRITE DA(%integer  block no)
      %record(parmfm)  p
      p_p4 = addr(block(0))
      p_p5 = DA KEY
      p_p6 = block no
      p_dact = da write;  svc(20,p)
      %if p_p6 < 0 %start
         print string("DA write: ".string(addr(p_p1)).SNL )
         %signal 15,15
      %finish
   %end

   %integerfn  HALF WORD(%integer  address)
      %integer  this block, disp
      %signal 15,15 %if address&1 # 0
      address = address + code offset %if address < gla start-code offset
      this block = address >> 9
      disp = address & 511
      %if current block # this block %start
         write da(current block) %if dirty # 0
         dirty = 0
         read da(this block)
         current block = this block
      %finish
      %result = short integer( addr(block(disp)) )
   %end
   %integerfn  WORD(%integer  address)
      %signal 15,15 %unless address&3 = 0
      %result = ( halfword(address)<<16) ! halfword(address+2)
   %end
   %routine  STORE WORD(%integer  word, address)
      %integer this block, disp
      %signal 15,15 %unless address&3 = 0
      address = address + code offset %if address < gla start-code offset
      this block = address >> 9
      disp = address & 511
      %if current block # this block %start
         write da(current block) %if dirty # 0
         read da(this block)
         current block = this block
      %finish
      dirty = 1
      integer( addr(block(disp)) ) = word
   %end

   %routine  RENAME (%string(31)  old name, new name)
      %record(parmfm)  old,new
      string(addr(old_sact)) = old name
      string(addr(new_sact)) = new name
      svc(17,old);  svc(17,new)
      %signal 15,15 %if old_p2 < 0 %or new_p2 < 0
      old_p5 = new_p3
      old_p6 = new_p4
      old_dact = 15;  svc(20,old)
      %if old_p6 < 0 %start
         print string("Rename failed"); newline
      %finish
   %end

   %constinteger  H = x'FFFF'

   %integer   code base = code seg<<16 + code offset,
              gla  base = gla  seg<<16

   %integer   code rel, gla rel
   %integer   k, p, rel, count
   %record(headfm)  head
   %string(31)  object file = root name . ".EXE"

   {initialise}
   open da(object file)
   read da(0)
   head = record( addr(block(code offset)) )
   %if head_registers # x'7DEF' %start
      print string("** ".object file." not an object file ?")
      newline
      close da
      %stop
   %finish

   code rel = code base + (head_code disp&H)*2
   gla rel  = gla  base
   gla  start = (head_pure size*2 + code offset + 511) & (\511)

   p = (head_reloc_base&H)*2
   count = head_reloc_n&H

   %while count > 0 %cycle
      rel = halfword(p)
      k = gla start + (rel>>1)<<2
      %if rel&1 # 0 %start
         store word( word(k)+code rel, k )
      %else
         store word( word(k)+gla  rel, k )
      %finish
      p = p+2
      count = count-1
   %repeat

   close da
   rename(root name.".EXE", root name. ".ABS")
%endofprogram
