%external %routine link11(%string (63) param)
   %string (63) map
   %own %integer brians fiddle= 255
   %const %integer limit= 128
   %own %integer code base= 2<<13, gla base = 0, spbase = 7<<13
   %own %integer alone= 0, main ep = -1, entry = 0
   %own %string (31) task id= ""
   %own %string (31) fix file= ""
   %own %integer streams= 2
   %own %string (31) perm file= ":imp119y.PERM11#REL",
                  lib  file = ":imp119y.LIB11#REL",
                  object    = ""
   %own %integer stack= 8*1024
   %const %integer plug bit= 64
   %external %integer %function %spec exist %alias "S#EXIST"(%string %c
      (255) file)
   %routine define(%string (255) s)
      %external %routine %spec emas3(%string %name command,params,
         %integer %name flag)
      %integer flag
      emas3("DEFINE",s,flag)
   %end;                                 ! Of %routine define.
   %external %string (6) %fn %spec IMP11HOST
   %external %routine %spec prompt %alias "S#PROMPT"(%string (255) s)
   %record %format tabfm(%integer addr,index, %byte %integer type,
      %string (63) text)
   %const %integer max table= 400
   %const %integer max files= 50
   %record (tabfm) %array table(0:max table)
   %string (63) %array file(1:max files)
   %integer %array filecode,filegla,specs,speclist(0:max files)
   %byte %integer %array used(1:max files)
   %integer errors
   %integer stream
   %integer refs,defs,module count
   %integer last code
   %integer ca,ga
   %integer file no,file limit
   %own %integer perm= 0, perm ep = 0
   %string (63) file name
   %integer j
   %record (tabfm) %name t
   %integer cp,gp,total ca,sp,ds
   %integer %array cbuf,gbuf(0:limit)
!Predefined externals
   %const %integer xtop= max table
   %const %integer xevent= max table-1
   %const %integer xds= max table-2
   %const %integer xsp= max table-3
   %const %integer 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) %c
      _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(%integer %name n)
      %integer s1,s2
      readch(s1); readch(s2)
      n = s1+s2<<8
   %end
   %routine read word(%string %name 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, %integer %name 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(%integer %array %name b, %integer %name 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(%integer %name 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(streams*x'280'+x'140');  !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(%integer %name 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) %else %c
            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(%integer %name n)
         %integer j
         %if sym='@' %then at = plug bit %and readsym %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(%integer %name 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 %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
%end %of %file