!
! MAKESHARE
!
!    Makeshare takes a PSR PDP-11 relocatable object
! module in on stream 1, and a text file containing
! driving information on stream 2, and produces a
! DEIMOS absolute loader format file for a shareable
! perm segment, and a descriptor file in relocatable
! format.  The load file contains all the code from
! the object, with a vector of transfer addresses
! loaded at the start.  The descriptor file contains
! the vector in the form of a set of absolute indirect 
! symbol definitions (eg PSYM = @20) and a glap area
! which defines certain control variables used by the
! the shared perm code and which are to be initialised
! by the linker using the normal reference mechanism. 
! This file is suitable for input to the linker, using
! the .SHARE keyword (normally done in the linker
! initialisation file). Currently all (non-code) refs
! remaining in the object file are assumed to refer to
! read-only data which will be allocated space, and
! loaded by the linker, in this fashion. MAKESHARE
! complains if a reference is specifed as being to a
! code item. 
!   The names of these external references are modified
! in such a fashion as to enable the shareable code to
! operate correctly.  Refs beginning with '.' are assumed
! to be refs to %name objects, and the names are left
! unchanged but the external reference generated (to be
! satisfied at link time, has the '.' removed.  Thus
! the shared code may access writeable data indirectly,
! providing the non-shared section of the library provides
! a data area which will be loaded into the gla area of
! the final task image. Other references are likewise
! left with the same definition name, but the value to
! which the word will be initialised is that of the symbol
! with '_' prefixed.
!
! example 1 -
!  in shareable library:
!
!    %external %record(event fm) %name %spec  ev %alias ".EVENT"
!
! in glap section defined by MAKESHARE:
!
!    .EVENT::  .word EVENT
! 
! example 2 -
!  in shareable library:
! 
!    %system %integer %spec  DS;     ! (initialised by linker)
! 
! in glap section:
! 
!    $DS::     .word _$DS
! 
!
!   The driver file contains the following information:
! 
! 1) The base address at which the communications 
! variables block is to be loaded (Normally 8_20 000).
! This is assumed to be an octal number.
!
! 2) A series of symbol names - each name represents
! a code entry point which 
!      a) should be defined in the input module,
!      b) will be assigned a transfer vector in the
!         shared segment,
! and  c) will appear in the descriptor file for
!         the segment.
! 
! Form of command:
!
!     makeshare  relfile,eplist/absfile,desfile
!
! default types (on systems with file-extensions):
!                 REL, EPL / ABS, REL
!
!  Mark Taunton
!  Edinburgh  September 1981
!

%const %integer  max text   = 10;       ! # sig chars in symbol names
%const %integer  max eps    = 400;      ! # vectored entry points
%const %integer  max gds    = 30;       ! # Data defs in object file
%const %integer  max cvs    = 30;       ! # Data references outstanding
%const %integer  buff limit = 128;      ! Code/glap buffers for loading

!D! %const %integer  max clp  = 79
!V! %const %integer  max clp  = 127
{E} %const %integer  max clp  = 255
!D! %const %integer  max f    = 12
{E} %const %integer  max f    = 31
!V! %const %integer  max f    = 127

!V! %const %integer  fatal error = 16_1000002C;    ! Exit code

%const %integer  report  = 0
%const %integer  rel in  = 1
%const %integer  epl in  = 2
%const %integer  abs out = 3
%const %integer  des out = 4

!DV! %external %string(maxf) %function %spec  EXPAND (%string(maxf) s)
!DV! %external %string(127)  %function %spec  SYSMESS (%integer n)
{VE} %external %routine %spec  SET DEFAULT (%string(maxf) s)
!V!  %system   %routine %spec  EXIT (%integer status)
!V!  %external %routine %spec  PRINT RECORD (%integer len, start)

!DV!%begin
{E} %external %routine  MAKE SHARE (%string(max clp)  cli param)

   ! Symbol type constants
   %const %integer  code def = 2
   %const %integer  glap def = 3
   %const %integer  code ref = 4
   %const %integer  abs  def = 8
   %const %integer  abs idef = 10

   %string(max text) %array  ep name (1 : max eps)
   %integer          %array  ep addr (1 : max eps)
   %string(max text) %array  g  name (1 : max gds)
   %integer          %array  g  addr (1 : max eps)
   %string(max text) %array  com var (1 : max cvs)

   %own %integer  eps, cvs, gdefs = 0
   %own %integer  cv base = 8_20 000
   %own %integer  ca, code, code base
   %own %integer  ga, glap, glap base

   %routine  CRASH (%string(127) why)
      select output (report)
      print string ("** MAKESHARE fails: ")
      print string (why)
      newline
!!!!!!%monitor
!DE!  %stop
!V!   exit (fatal error)
   %end

   %routine  OCTAL (%integer n)
      %integer  p
      print symbol (n>>p&7+'0') %for p = 15, -3, 0
   %end

   %routine  GETB (%integer %name  b)
      %on 9 %start
         crash ("EOF on input file")
      %finish
!DV!  read symbol (b)
{E}   read ch (b)
   %end

   %routine  GETW (%integer %name  w)
      %integer lo, hi
      getb (lo);   getb (hi)
      w = lo + hi<<8
   %end

   %routine  GETS (%string(*) %name  s)
      %integer len, p, c
      getb (len);  s = ""
      %for p = 1, 1, len %cycle
         getb (c)
         s = s . tostring (c) %if p <= max text
      %repeat
   %end

   %routine  PUTB (%integer n)
!DV!  print symbol (n)
{E}   print ch (n)
   %end

   %routine  PUTW (%integer n)
      putb (n);  putb (n>>8)
   %end

   %routine  PUTS (%string(max text*2)  symbol)
      %integer  len, p
      len = length(symbol)
      len = max text %if len > max text
      putb (len)
      putb (charno (symbol, p)) %for p = 1, 1, len
   %end

   %routine  OPEN FILES
      %string(max clp)  param, rel, epl, abs, des

      %routine  OPEN (%integer dir, sno, %string(maxclp) file, %string(3) ext)
         %string(max clp) reason

         %on 9 %start
{E}         reason = event_message
{E}         reason = file . " -- " . reason %unless reason -> (file)
!DV!        reason = file . " -- " . sysmess (event_extra)
            crash (reason)
         %finish

{E}      set default ("#".ext)
!V!      set default (".".ext)
!DV!     file = expand (file)
         %if dir = 'i' %start
            open input (sno, file) 
            select input (sno)
         %finish %else %start
            ext = ""
!V!         ext = "-b" %if dir < 0
            open output (sno, file.ext)
            select output (sno)
         %finish
      %end

      param = cli param
      -> fail %unless param -> rel . (",") . param %and rel # ""
      -> fail %unless (param -> epl . ("/") . param %or %c
                       param -> epl . (",") . param)  %and epl # ""
      -> fail %unless param -> abs . (",") . des %and abs # "" # des
      open ('i',  rel  in, rel, "REL")
      open ('i',  epl  in, epl, "EPL")
      open ('o',  abs out, abs, "ABS")
      open (-'o', des out, des, "REL")
      %return
fail:
      crash ("command is MAKESHARE relfile,eplist/absfile,desfile")
   %end

   %routine  GET ENTRY POINTS
      %string(max text) ep
      %integer j

      %routine  GET WORD (%string(max text) %name s)
         %integer  c
         %on 9 %start
            s = ""
            %return
         %finish
         s = ""
         read symbol (c) %until ' ' # c # nl
         %cycle
            c = c - 'a' + 'A' %if 'a' <= c <= 'z'
            s = s . tostring(c) %if length(s) < max text
            read symbol (c)
         %repeat %until c = ' ' %or c = nl
      %end

      eps = 0
      select output (report)
      %cycle
         get word (ep)
         %exit %if ep = ""
         eps = eps + 1;   ep name (eps) = ep
         %for j = 1, 1, eps-1 %cycle
            %if ep = ep name (j) %start
               print string ("Entry point """);  print string (ep)
               print string (""" specifed twice?");  new line
               eps = eps - 1
               %exit
            %finish
         %repeat
      %repeat
   %end

   %routine  GET HEADER
      %integer  nrefs, ndefs, d, r, ec, eg, mcount

      %routine  GET DEF
         %integer l, p, c, type, d, a
         %string(max text)  name
         getw (a);  getb (type);   gets (name)
         %if type = glap def %start
            gdefs = gdefs + 1
            crash ("Too many data defs in module") %if gdefs > max gds
            g name(gdefs) = name
            g addr(gdefs) = a
         %finish %else %if type = code def %start
            %for d = 1, 1, eps %cycle;      ! search list of wanted E/Ps
               %if ep name(d) = name %start
                  %if type = code def %start
                     ep addr(d) = a + code base
                     %exit
                  %finish
                  crash ("Symbol """.name.""" is not a code address")
               %finish
            %repeat
         %finish
      %end

      %routine  GET REF
         %integer l, p, c, type, d, a
         %string(max text)  name
         getb (type);  gets (name)
         %if charno(name,1) # '.' %and type = code ref %start
            crash ("Code reference """.name.""" outstanding!")
         %finish
         cvs = cvs + 1
         print string ("Reference """);  print string (name)
         print string (""" at 8_");  octal (cv base+cvs<<1-2)
         com var(cvs) = name
         newline
      %end

      cvs = 0
      code base = eps*2;                  ! Code starts after entry vector
      select input (rel in);  select output (report)
      getw (mcount)
      crash ("File does not contain exactly 1 module!!") %if mcount # 1
      getw (ndefs)
      get def %for d = 1, 1, ndefs
      getw (nrefs)
      get ref %for r = 1, 1, nrefs
      getw (code);   getw (glap)
      ec = code + eps*2;  glap base = ec; ! Gla starts after code section
      eg = (ec + glap + 1) & (\1)
      crash ("Module will not fit in 1 segment") %unless 0 < eg <= 8192
   %end

   %routine  GENERATE LOAD FILE
!DV!  %own %short %array  cbuf (-2 : buff limit+1)
!DV!  %own %short %array  gbuf (-2 : buff limit+1)
{E}   %own %integer %array  cbuf (-2 : buff limit+1)
{E}   %own %integer %array  gbuf (-2 : buff limit+1)
      %own %integer  cp = 0, gp = 0, last code = 0
      %integer  j

!DV!  %routine  FLUSH (%short   %array %name  b,
!DV!                   %integer %name  p, %integer  new)
{E}   %routine  FLUSH (%integer %array %name  b, %c
{E}                    %integer %name  p, %integer  new)
         %integer check, w, bp, bc

         check = 0;  bc = p + p + 6
         b(-2) = 1
         b(-1) = bc
         %for bp = -2, 1, p %cycle
            w = b(bp)
            check = check + w&255 + w>>8&255
         %repeat
         b(p+1) = (-check)&255

!V!      print record (bc+1, addr(b(-2)))
!DE!     putb (0) %for bp = 1, 1, 4
!DE!     putw (b(bp)) %for bp = -2, 1, p
!DE!     putb (b(p+1)&255)

         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 = buff limit
      %end

      %routine  GPUT (%integer n)
         gp = gp + 1;  gbuf(gp) = n
         ga = ga + 2
         flush (gbuf, gp, ga) %if gp = buff 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  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 MODULE
         %integer cb, gb, key, n, index, line, mod
         %switch s(1:11)
         cb = ca;  gb = ga;  mod = 0
         %cycle
            getb (key)
            -> s (key) %if 1 <= key <= 11
      s(3): crash ("Corrupt object file!");  ! Unused code

      s(1): getw (n);  cput (n+mod);  mod = 0;  %continue
      s(2): getw (n);  gput (n+mod);  mod = 0;  %continue
      s(4): getw (n);  getw (index)
            plug gla (n+cb, index+gb);          %continue
      s(5): getw (n);  locate (n+cb);           %continue
      s(6): getw (line);                        %continue
      s(7): getw (index);
            mod = mod + cv base + (index-1)<<1; %continue
      s(9): mod = mod + cb;                     %continue
      s(10):mod = mod + gb;                     %continue
      s(11):mod = mod - (ca + 2)
         %repeat
      s(8):
         getw (n);                         ! event chain?
         getb (n); getb (n); getb (n);     ! 16_E0E0E0
      %end

      select output (abs out)
      ca = 0;   ga = 0
      cput (ep addr(j)) %for j = 1, 1, eps
      reset (code base, glap base)
      load module
      flush (cbuf, cp, ca) %if cp # 0
      flush (gbuf, gp, ga) %if gp # 0

   %end

   %routine  GENERATE DESCRIPTOR FILE
      %integer  d, k, csize, cend, pad
      %string(max text+1)  s

      select output (des out)
      putw (1);                               ! Module count
      putw (eps+cvs+gdefs);                   ! total definitions
      %for d = 1, 1, eps %cycle
         putw (d*2-2);                        ! address of vector
         putb (abs idef);                     ! type - vectored definition
         puts (ep name(d));                   ! text
      %repeat
      %for d = 1, 1, cvs %cycle;              ! Define all comms variables
         putw (cv base+d*2-2);                ! Address of variable
         putb (abs def);                      ! type - absolute address
         puts (com var(d));                   ! Actual name
      %repeat
      %for d = 1, 1, gdefs %cycle
         putw (glap base+g addr(d));          ! Gla area (const!) definition
         putb (abs def);                      ! Absolute
         puts (g name(d));                    ! Var name
      %repeat
      putw (cvs);                             ! #refs
      %for d = 1, 1, cvs %cycle;              ! refs to initialisation values
         s = com var(d)
         putb (0);                            ! Unknown type
         %if charno(s,1) = '.' %start;        ! %name-type reference
            s = sub string (s, 2, length(s)); ! .JIM:: .word JIM
            crash ("Ref "".""????") %if s = ""
         %finish %else %start
            s = "_" . s;                      ! FRED:: .word _FRED
         %finish
         puts (s)
      %repeat
      csize = cvs*2+2;                        ! Total code inc. event word
      pad = 0;                                ! Event block padding
      pad = 2 %if (cv base+csize)&3 = 0;      ! End address rounded up to 4
      csize = csize + pad
      putw (csize);                           ! Code size
      putw (0);                               ! Glap = 0
      %for  d = 1, 1, cvs %cycle
         putb (7);  putw (d);                 ! Add addr(X-ref d) to next plant
         putb (2);  putw (0);                 ! Plant glap word
      %repeat
      putb (2) %and putw (0) %if pad # 0
      cend = cv base + csize
      putb (2);                               ! Event word at end of glap!!
      putw ((cend-code+eps*2)<<1);            ! Link to end of shared e-chain
      putb (8);   putw (cend);                ! Event chain (ignored)
      putb (16_E0);  putw (16_E0E0);          ! End of module
      close output
   %end

! Main Code

   open files
   get entry points
   get header
   generate load file
   generate descriptor file

%end

%end %of %file