%externalroutine link11(%string(63) param)
   %string(63) map
   %owninteger brians fiddle = 255
   %constinteger limit = 128
   %owninteger code base = 2<<13, gla base = 0, spbase = 7<<13
   %owninteger alone = 0, main ep = -1, entry = 0
   %ownstring(31) task id = ""
   %ownstring(31) fix file = ""
   %owninteger streams = 2
   %ownstring(31) perm file = ".PERM11#REL", %c
                  lib  file = ".LIB11#REL",  %c
                  object    = ""
   %owninteger stack = 8*1024
   %constinteger plug bit = 64
   %externalintegerfnspec exist(%string(255) s)
   %externalroutinespec define(%string(63) s)
   %EXTERNALSTRING(6) %FNSPEC IMP11HOST
   %externalroutinespec prompt(%string(15) s)
   %recordformat tabfm(%integer addr, index, %c
                       %byteinteger type, %string(63) text)
   %constinteger max table = 400
   %constinteger max files = 50
   %record(tabfm)%array table(0:max table)
   %string(63)%array file(1:max files)
   %integerarray filecode, filegla, specs, speclist(0:max files)
   %byteintegerarray used(1:max files)
   %integer errors
   %integer stream
   %integer refs, defs, module count
   %integer last code
   %integer ca, ga
   %integer file no, file limit
   %owninteger perm = 0, perm ep = 0
   %string(63) file name
   %integer j
   %record(tabfm)%name t
   %integer cp, gp, total ca, sp, ds
   %integerarray cbuf, gbuf(0:limit)
!Predefined externals
   %constinteger xtop   = max table
   %constinteger xevent = max table-1
   %constinteger xds    = max table-2
   %constinteger xsp    = max table-3
   %constinteger xgo    = max table-4
!
   table(xtop)_text   = "$TOP";   table(xtop)_type  =0;  table(xtop)_index  =0
   table(xevent)_text = "$EVENT"; table(xevent)_type=0;  table(xevent)_index=0
   table(xds)_text    = "$DS";    table(xds)_type   =0;  table(xds)_index   =0
   table(xsp)_text    = "$SP";    table(xsp)_type   =0;  table(xsp)_index   =0
   table(xgo)_text    = "$$$";    table(xgo)_type   =0;  table(xgo)_index   =0
!
   PERM FILE=IMP11HOST.PERM FILE
   LIB FILE = IMP11HOST.LIB FILE
!
   %routine octal(%integer n)
      %integer j
      %cycle j = 15, -3, 0
         printsymbol(n>>j&7+'0')
      %repeat
   %end
   %routine select(%integer st)
      stream = st
      selectoutput(stream)
   %end
   %routine get(%integername n)
      %integer s1, s2
      readch(s1);  readch(s2)
      n = s1+s2<<8
   %end
   %routine read word(%stringname s)
      %integer sym
      s = ""
      skipsymbol %while nextsymbol = ' ' %or nextsymbol = nl
      %cycle
         sym = nextsymbol
         %return %if sym = ' ' %or sym = nl %or sym = '='
         sym = sym-32 %if 'a' <= sym <= 'z'
         s = s.tostring(sym)
         skipsymbol
      %repeat
   %end
   %routine error(%string(100) text)
      selectoutput(0)
      printstring("* ")
      printstring(text);  newline
      errors = errors+1
      selectoutput(stream)
   %end
   %routine get record(%record(tabfm)%name r, %integer spec)
!NOTIMP80       %RECORDSPEC R(TABFM)
      %integer j,n,s

      %if spec # 0 %then r_addr = 0 %else get(r_addr)
      r_index = file no
      readch(r_type)
      readch(n)
      r_text = ""
      %cycle j = 1, 1, n
         readch(s)
         r_text = r_text.tostring(s)
      %repeat
   %end
   %routine get spec
      %integer j
      %record(tabfm) r
      %record(tabfm)%name t
      get record(r, 1)
      r_index = 0
      refs = refs+1;  table(refs) = r
      %cycle j = 1, 1, refs
         %exit %if table(j)_text = r_text
      %repeat
      t == table(j)
      %if r_type # 0 %and t_type # r_type %start
         error("inconsistent use of ".r_text)
         defs = defs-1;  table(defs) = r
         %return
      %finish
   %end
   %routine get def
      %integer j
      %record(tabfm) r
      get record(r, 0)
      r_index = file no
      perm ep = file no %if r_text = "$GO$"
      defs = defs-1;  table(defs) = r
      %cycle j = max table, -1, defs
         %exit %if table(j)_text = r_text
      %repeat
      %return %if j = defs
      defs = defs+1
      error("duplicate ".r_text) %if perm = 0
   %end
   %routine satisfy(%record(tabfm)%name r)
!NOTIMP80      %RECORDSPEC R(TABFM)
      %record(tabfm)%name t
      %integer j
      %cycle j = max table, -1, defs
         t == table(j)
         %if t_text = r_text %start
            r_addr = t_addr;  r_type = t_type
            t_type = t_type!32;    !SHOW USED
            %return
         %finish
      %repeat
      error("unsatisfied reference ".r_text." in file ".file name)
   %end
   %routine prepare specs(%integer insert, %integername flag)
      %record(tabfm) r
      %integer n
      flag = errors
      get(n)
      %while n > 0 %cycle
         get record(r, 0)
         n = n-1
      %repeat
      get(n)
      %while n > 0 %cycle
         n = n-1
         get record(r, 1)
         %continue %if insert = 0
         satisfy(r)
         refs = refs+1;  table(refs) = r
      %repeat
      flag = errors-flag
      get(n);     !CODE SIZE
      get(n);     !GLA SIZE
   %end
   %routine skip module
      %integer s
      %cycle
         readch(s) %until s = x'E0'
         readch(s)
         %if s = x'E0' %start
            readch(s)
            %return %if s = x'E0'
         %finish
      %repeat
   %end
   %routine flush(%integerarrayname b, %integername p, %integer new)
      %integer j, check
      %routine put(%integer n)
         printch(n&255);  printch(n>>8)
         check = check+n+n>>8
      %end
      %cycle j = 1, 1, 10
         printch(0)
      %repeat
      check = 0
      put(1)
      put(p*2+6)
      %cycle j = 0, 1, p
         put(b(j))
      %repeat
      printch( (-check)&255 !brians fiddle )
      brians fiddle = 0
      p = 0
      b(0) = new
   %end
   %routine cput(%integer n)
      last code = n
      cp = cp+1;  cbuf(cp) = n
      ca = ca+2
      flush(cbuf, cp, ca) %if cp = limit
   %end
   %routine gput(%integer n)
      gp = gp+1;  gbuf(gp) = n
      ga = ga+2
      flush(gbuf, gp, ga) %if gp = limit
   %end
   %routine plug gla(%integer what, where)
      flush(gbuf, gp, where) %if gp # 0
      gbuf(0) = where
      gbuf(1) = what
      gp = 1
      flush(gbuf, gp, ga)
   %end
   %routine locate(%integer at)
      flush(cbuf, cp, at) %if cp # 0
      cbuf(0) = at
      ca = at
   %end
   %routine plug code(%integer what)
      %if cp # 0 %start
         cbuf(cp) = what
      %finish %else %start
         locate(ca-2)
         cput(what)
      %finish
   %end
   %routine load module(%integer base)
      %integer cb, gb, key, n, index, line, mod
      %record(tabfm)%name t
      %switch s(1:12)
      cb = ca;  gb = ga;  mod = 0
      %cycle
         readch(key)
         ->s(key)
s(1):    get(n);  cput(n+mod);  mod = 0;  %continue
s(2):    get(n);  gput(n+mod);  mod = 0;  %continue
s(7):    get(index)
         t == table(index+base)
         %if t_type&plug bit # 0 %start
            %if last code # k'004737' %start;   !JSR_PC,#???
               error("Cannot fixup ".t_text)
               t_type = 0
            %finish
            plug code(k'004777');                !JSR_PC,@#???
            mod = mod-ca-2
         %finish
         mod = mod+t_addr
         %continue
s(4):    get(n);  get(index)
         plug gla(n+cb, index+gb)
         %continue
s(5):    get(n);  locate(n+cb);  %continue
s(9):    mod = mod+cb;     %continue
s(10):   mod = mod+gb;     %continue
s(11):   mod = mod-ca-2;   %continue
s(6):    get(line)
      %repeat
s(8): get(n);  n = n+cb;        !EVENT CHAIN?
      readch(n);  readch(n);  readch(n)
   %end
   %routine header
      %integer total ca, j, g
      %routine strip(%integer seg)
         %routine add(%integername n)
            n = n-8*1024
            %if n >= 0 %then cput(8*1024) %else cput(n+8*1024)
         %end
         %if total ca > 0 %start
            cput(5);  add(total ca)
         %finish %else %start
            %if ga > 0 %and seg >= g %start
               cput(6);  add(ga)
            %finish %else %start
               cput(4);  cput(0)
            %finish
         %finish
      %end
         total ca = ca-codebase
         ga = sp-glabase
         g = glabase>>13
      locate(0)
      !
      task id = task id."    "
      cput(charno(task id, 1)+charno(task id, 2)<<8)
      cput(charno(task id, 3)+charno(task id, 4)<<8)
      cput(sp);                          !INITIAL SP
      cput(4);  cput(0);                 !SEG 0
      cput(7);  cput(0);                 !SEG 1
      strip(2);                          !SEG 2
      strip(3);                          !SEG 3
      strip(4);                          !SEG 4
      strip(5);                          !SEG 5
      strip(6);                          !SEG 6
      cput(6);  cput(2000);              !SEG 7
      locate(code base)
      %cycle j = 1, 1, 8
         cput(0)
      %repeat
   %end
   %routine reset(%integer c, g)
      flush(cbuf, cp, ca) %unless cp = 0
      flush(gbuf, gp, ga) %unless gp = 0
      cbuf(0) = c;  ca = c
      gbuf(0) = g;  ga = g
   %end
   %routine load(%integer modules)
      %integer flag, base, no, use
      no = file no
      use = used(no)
      base = refs
      prepare specs(use, flag)
      file no = file no+1 %and load(modules-1) %if modules > 1
      reset(filecode(no), filegla(no))
      %if flag # 0 %or use = 0 %start
         skip module
      %finish %else %start
         load module(base)
      %finish
   %end
   %routine get module(%integername codesize, glasize)
      %integer n
      get(n);     !NO OF DEFINITIONS
      %while n > 0 %cycle
         n = n-1
         get def
      %repeat
      get(n);     !NO OF REFERENCES
      speclist(file no) = refs
         specs(file no) = n
      %while n > 0 %cycle
         n = n-1
         get spec
      %repeat
      get(code size)
      get(gla size)
   %end
   %routine examine(%integer modules)
      %cycle
         file no = file no+1
         file(file no) = file name;  file name = ""
         get module(file code(file no), file gla(file no))
         modules = modules-1
         %return %if modules = 0
      %repeat
   %end
   %routine fill refs
      %record(tabfm)%name r
      %integer ref, def
      %return %if refs = 0 %or defs = 0
      %cycle ref = 1, 1, refs
         r == table(ref)
         %cycle def = max table, -1, defs
            %if table(def)_text = r_text %start
               r_index = table(def)_index
               %exit
            %finish
         %repeat
      %repeat
   %end
   %routine mark(%integer module index)
      %integer p, n, c, g
      %return %if module index = 0 %or used(module index) # 0
      used(module index) = 1
      c = ca
      ca = ca+file code(module index)
      file code(module index) = c
      g = ga
      ga = ga+file gla(module index)
      file gla(module index) = g
      p = spec list(module index)
      n = specs(module index)
      %while n > 0 %cycle
         n = n-1
         p = p+1
         mark(table(p)_index)
      %repeat
   %end
   %routine fix addresses
      %integer j, b
      %record(tabfm)%name t
      %return %if defs > max table
      %cycle j = defs, 1, max table
         t == table(j)
         %if t_type&1 # 0 %then b = file gla(t_index) %c
                          %else b = file code(t_index)
         t_addr = t_addr+b
      %repeat
   %end
   %routine handle fixups(%string(63) fix file)
      %string(63) fixup
      %integer sym, j, at, n
      %record(tabfm)%name t
      %routine readsym
         readsymbol(sym) %until sym # ' '
         sym = sym-32 %if 'a' <= sym <= 'z'
      %end
      %routine read octal(%integername n)
         %integer j
         %if sym = '@' %then at = plug bit %and readsym %c
                       %else at = 0
         n = 0
         %cycle j = 1, 1, 6
            %exit %unless '0' <= sym <= '7'
            n = n<<3+(sym-'0')
            readsym
            %return %if sym = nl
         %repeat
         error("Bad address for fixup ".fixup)
      %end
      !
      %return %if fix file = ""
      %if exist(fixfile) = 0 %start
         printstring(fixfile." does not exist");  newline
         %return
      %finish
      define("ST2,".fixfile);  selectinput(2)
      %cycle
         read word(fixup);  %exit %if fixup = ".END"
         readsym
         %if sym # '=' %start
            error("No = in fixup for ".fixup)
         %finish %else %start
            readsym;  read octal(n)
            defs = defs-1;  t == table(defs)
            t_text = fixup;  t_index = 0;  t_addr = n;  t_type = 128!at
            %cycle j = max table, -1, defs
               %exit %if table(j)_text = fixup
            %repeat
            defs = defs+1 %if j # defs
         %finish
         readsym %while sym # nl
      %repeat
      selectinput(1);  close stream(2)
   %end
   %routine get octal(%integername n)
      %integer s
      n = 0
      readsymbol(s) %until '0' <= s <= '7'
      %cycle
         n = n<<3!(s-'0')
         readsymbol(s)
         %return %unless '0' <= s <= '7'
      %repeat
   %end
   %routine process(%string(63) file)
      file name = file
      %return %if file = ""
      %if exist(file name) = 0 %start
         file name = file name."#REL"
         %if exist(file name) = 0 %start
            printstring(file." does not exist");  newline
            %return
         %finish
      %finish
      define("ST2,".file name)
      select input(2)
      get(module count)
      examine(module count)
      select input(1)
      close stream(2)
   %end
   !
   map = ".OUT" %unless param -> param.("/").map %c
                   %or param -> param.(",").map
   param = ".IN" %if param = ""
   define("ST1,".param)
   %cycle j = 1, 1, max files
      used(j) = 0
   %repeat
   table(0) = 0;  filecode(0) = 0;  filegla(0) = 0
   ca = code base+16;  ga = 16;  !LEAVE SPACE FOR ENTRY INSTRUCTIONS
   errors = 0
   file no = 0
   refs = 0;  defs = max table-4
!
   select(0)
   selectinput(1)
   %cycle
      prompt("Link:   ")
      read word(file name)
      %if charno(file name, 1) = '.' %start
         %exit %if file name = ".END"
         %if file name = ".STACK" %start
            get octal(stack);  %continue
         %finish
         %if file name = ".NAME" %start
            prompt("Task name:")
            read word(file name)
            length(file name) = 4 %if length(file name) > 4
            task id = file name
            %continue
         %finish
         %if file name = ".FIXUP" %start
            read word(fix file)
            handle fixups(fix file)
            %continue
         %finish
         %if file name = ".ENTRY" %start
            prompt("Entry point: ");  get octal(main ep)
            entry = 1
            file name = ".ALONE"
         %finish
         %if file name = ".ALONE" %start
            prompt("Start of store:");  get octal(code base)
            prompt("  End of store:");  get octal(  sp base)
            ca = code base;  ga = 0
            alone = 1
            brians fiddle = 0
            %continue
         %finish
         %if file name = ".STREAMS" %start
            get octal(streams);  %continue
         %finish
         %if file name = ".NOLIB" %start
            lib file = ""
            %continue
            %finish
            %if file name = ".NOPERM" %start
               perm file = "";  %continue
            %finish
            printstring("Unknown keyword ".file name)
            newline
            %continue
      %finish
      process(file name)
   %repeat
   perm = 1
   process(lib file)
   process(perm file)
   %return %if errors # 0
   cp = 0;  gp = 0;  gbuf(0) = ga
   table(xtop)_addr = ca+2;     !CODE TOP
!!!HANDLE FIXUPS(FIX FILE)
   fill refs
   ca = code base
   %if entry # 0 %start
      mark(1);            !LOAD THE MAIN PROGRAM
   %finish %else %start
      ca = code base+16 %if alone = 0
      main ep = ca
      error("No main entry point!") %if perm ep = 0
      mark(perm ep);     !LOAD $GO$
   %finish
   table(xgo)_addr = 0
   sp = spbase&(\1)
      glabase = ca
      glabase = (7<<13-ga-stack)&k'160000' %if alone = 0
      ds = (glabase+ga+7)&(\7)
      sp = (ds+stack)&(\1) %if alone = 0
      table(xsp)_addr = sp
      error("No space for stack") %if sp > spbase %or ds >= sp
      %cycle j = 0, 1, file no
         file gla(j) = file gla(j)+gla base
      %repeat
   table(xds)_addr = ds
   table(xevent)_addr = ca-2
   fix addresses
   prompt("Object: ")
   read word(object)
   define("ST3,".object)
   task id = object %if task id = ""
   select(3)
   header %if alone = 0
   file limit = file no
   file no = 0
   %while file no < file limit %cycle
      file no = file no+1
      file name = file(file no)
      %if file name = "" %start
         error("Linker phase error!!!");  %return
      %finish
      define("ST2,".file name)
      select input(2)
      get(module count)
      refs = 0
      load(module count)
      select input(1)
      close stream(2)
   %repeat
   flush(gbuf, gp, ga) %if gp # 0
   locate(main ep)
   flush(cbuf, cp, ca)
   %return %if errors # 0
   select output(0)
   printstring("Linking complete");  newline
   define("ST2,".map);  select output(2)
!MAP
   newline
   ca = 0;  ga = 0
   %cycle j = max table, -1, defs
      t == table(j)
      %if t_type&32 # 0 %start
         %if ca&3 = 0 %then newline %else spaces(ga)
         ca = ca+1
         octal(t_addr)
         space
         printstring(t_text)
         ga = 12-length(t_text)
      %finish
   %repeat
   newline
      newline
      %cycle j = 1, 1, file no
         %continue %if used(j) = 0 %or file(j) = ""
         octal(file code(j));  space
         octal(file  gla(j));  space
         printstring(file(j))
         newline
      %repeat
      newline
      printstring("SP = ");  octal(sp);  newline
      printstring("DS = ");  octal(ds);  newline
%end
%endoffile