{V} %system %routine %spec  EXIT (%integer status)
%const %integer  max text = 10
{V}%const %integer  fatal err = 16_1000002C

%const %integer  report = 0, abs in = 1, rel out = 2

{DV}%begin
!E! %external %routine  CON11 (%string(maxclp) cliparam)
   %string(127) file = cliparam
   %ownstring(31) text type = "Entry point "
   %const %integer  maxcode = 20000
   %const %integer  glamod = 1, evmod = 2
   %const %integer  nrec = 200
   %integerarray code(-20:maxcode)
   %integer modules, len, check, at, s, p ,j, start, m
   %integer flag, specs, spec ad, spec index, size

   %recordformat efm(%integer start, finish, flag, %string(10) text)
   %recordformat sfm(%integer chain, index, %string(10) text)

   %record(efm)%array entry(1:nrec)
   %record(sfm)%array spec(1:nrec)
   %record(efm)%name e
   %record(sfm)%name sp

   %routine  CRASH (%string(80) why)
      select output (report)
      print string ("** CON11 fails: ")
      print string (why)
      newline
!DE!  %stop
{V}   exit (fatal err)
   %end

   %string(6) %function  OCTAL (%integer n)
      %string(6) res;   res = ""
      %integer j
      n = n & 8_177777
      %for j = 15, -3, 0 %cycle
         res = res . tostring(n>>j&7+'0')
      %repeat
      %result = res
   %end

   %routine  GETB (%integer %name  n)
      %on 9 %start
         crash ("Unexpected EOF")
      %finish
!E!   readch (n)
{DV}  read symbol (n)
   %end

   %routine  GET (%integer %name  n)
      %integer  s1, s2
      getb (s1);  getb (s2)
      check = check + (s1+s2)
      n = s1 + s2<<8
   %end

   %routine  GET TEXT (%string(*) %name s)
      %integer n, j, c
      n = code(p)&255
      s = ""
      %for j = 1, 1, n %cycle
         %if j&1 = 0 %start
            p = p+1;  size = size-2
            c = code(p)&255
         %else
            c = code(p)>>8
         %finish
         s = s . tostring(c) %if j <= max text
      %repeat
      p = p+1;  size = size-2
      flag = 0
      c = charno(s, n)
      %if c = '%' %or c = '!' %start; ! Frigg for events, gla
         flag = evmod
         flag = glamod %if c = '%'
         length (s) = length(s) - 1
      %finish
      select output (report)
      print string (text type)
      print string (s)
      print string (" *E")  %if flag = evmod
      print string (" *G") %if flag = glamod
      newline
      select output (rel out)
   %end

   %routine  GET NEXT SPEC (%record(efm) %name t)
      %record(sfm) %name  sp, s
      %integer j
      spec ad = 32000
      %for j = 1, 1, specs %cycle
         s == spec(j)
         %if s_chain <= t_finish %and 0 < s_chain < spec ad %start
            sp == s
            spec ad = s_chain
         %finish
      %repeat
      %return %if spec ad = 32000
      spec index = sp_index
      sp_chain = code(sp_chain)
   %end

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

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

   %routine  DUMP CODE (%record(efm) %name t)
      %integer j, mode
      get next spec (t)
      mode = 1; mode = 2 %if t_flag = glamod
      %for j = t_start, 1, t_finish %cycle
         %if j = spec ad %start
            putb (7); putw (spec index)
            putb (mode);putw (0)
            get next spec (t)
         %else
            putb (mode); putw (code(j))
         %finish
      %repeat
      j = t_finish-t_start+2
      %if t_flag = 0 %start;        ! no own event block, not gla
         %if j&1 # 0 %start;        ! Pad to mult of 4 bytes
            j = j+1
            putb (1); putw (0)
         %finish
         putb (1); putw (j*4)
      %finish
      putb (8); putw (0)
      putb (16_e0);  putb (16_e0);  putb (16_e0);
   %end

   %routine  DUMP TEXT (%string(max text) s)
      %integer j, n
      n = length(s)
      putb (n)
      %for j = 1, 1, n %cycle
         putb (charno(s,j))
      %repeat
   %end

   %routine  DUMP DEF (%record(efm) %name t)
      %integer type
     putw (1);                        ! 1 definition
     putw (0);                        ! address
      type = 2;                       ! Code def
      type = 3 %if t_flag = glamod;   ! Glap def
      putb (type)
      dump text (t_text)
   %end

   %routine  DUMP SPECS (%integer  start, finish)
      %integer  j, n, ad
      %record(sfm) %name  s
      n = 0
      %for j = 1, 1, specs %cycle
         s == spec(j)
         s_index = 0
         ad = s_chain
         %while 0 < ad <= finish %cycle
            %if ad >= start %start
               n = n + 1
               s_index = 1
               %exit
            %finish
            ad = code(ad)
         %repeat
      %repeat
      putw (n)
      %return %if n = 0
      %for j = 1, 1, specs %cycle
         s == spec(j)
         %if s_index # 0 %start
            putb (0);          ! unknown ref type
            dump text (s_text)
         %finish
      %repeat
   %end

   %routine  EXTRACT SPECS (%record(efm) %name  e)
      %integer  j, index
      %record(sfm) %name  s
      %return %if specs = 0
      index = 0
      %for j = 1, 1, specs %cycle
         s == spec(j)
         %if e_start <= s_chain <= e_finish %start
            index = index+1
            s_index = index
         %finish
      %repeat
   %end

   %routine  REVERSE (%integer %name  n)
      %integer  x, z
      x = 0
      %while n # 0 %cycle
         z = n>>1
         n = code(z)
         code(z) = x
         x = z
      %repeat
      n = x
   %end

   ! Main Code

!E!%if (input -> input . ("/") . output %or %c
!E!     input -> input . (",") . output) %and %c
!E!     input # "" # output %start
!E!   croak (input." does not exist") %if exist (input) = 0
!E!   ssfoff
!E!   define ("1,".input);  ssfon %and croak (ssfmessage) %if ssfail # 0
!E!   croak ("Form: con11 absfile/relfile")
!E!%finish
   open input (abs in, file.".abs")
   open output (rel out, file.".rel-B")
   select input (abs in)
   select output (rel out)
   code(p) = 0 %for p = -20, 1, maxcode
   %cycle
!E!   getb (s) %until s = 1 %and next ch = 0
{DV}  getb (s) %until s = 1 %and next symbol = 0
      getb (s)
      check = 1
      get (len)
      get (start)
      at = start//2
      len = len-6
      %exit %if len <= 0
      %while len > 0 %cycle
         len = len-2
         get (s)
         code(at) = s
         at = at+1
      %repeat
      getb (s);        !checksum
      %if (check+s)&255 # 0 %start
         crash ("Checksum error (" . itos ((check+s)&255, 0) . %c
                ") in block at address ". octal (start))
      %finish
   %repeat

   modules = 0
   p = -20
   p = p+1 %while code(p) = 0
   %cycle
      size = code(p);  p = p+1
      %exit %if size = 0
      modules = modules+1
      e == entry(modules)
      get text (e_text)
      e_flag = flag
      %if size&1 # 0 %start
         crash (e_text." has an odd number of bytes!")
      %finish
      e_start = p
      p = p+size>>1-1
      e_finish = p-1
   %repeat
   text type = "External reference "
   specs = 0
   %cycle
      m = code(p)
      %exit %if m = 0
      specs = specs+1
      sp == spec(specs)
      get text(sp_text)
      sp_chain = code(p);  p = p+1
      sp_index = 0
      reverse(sp_chain)
   %repeat
   select output(rel out)
   putw (modules)
   %for j = modules, -1, 1 %cycle
      e == entry(j)
      dump def(e);  dump specs(e_start, e_finish)
      m = (e_finish-e_start+1)*2
      %if e_flag # glamod %start
         m = m + 2 %if e_flag = 0;  ! add event block
         putw((m+2)&(\2));          ! code size
         putw(0);                   ! gla size
      %else;                        ! Gla module
        putw (0)
        putw (m)
      %finish
   %repeat
   putb (6);   putw (0);            ! Give code11 a push.. ???
   %for j = 1, 1, modules %cycle
      extract specs(entry(j))
      dump code(entry(j))
   %repeat

%endofprogram