%external %routine pass3;                !PASS3 FOR PDP11 IMP
   %external %integer shortjumps=0
   %external %integer mediumjumps=0
   %external %integer longjumps=0
   %external %real stretch time= 0
   %external %long %real %function %spec cpu time %alias "S#CPUTIME"
                                         !INFO BITS   &1 = NO SHORT JUMPS
                                         !            &2 = NO JUMPS ROUND JUMPS
                                         !            &4 = NO DEFERAL OF JUMPS
                                         !            &8 = NO TAILORED ENTRY

!               OBJECT FILE FORMAT
!
!         +============================+
!         !   NUMBER OF DEFINITIONS    !
!         +----------------------------+
!         !                            !
!         !        DEFINITIONS         !
!         !   ADDR<2> TYPE<1> "TEXT"   !
!         !                            !
!         +----------------------------+
!         !    NUMBER OF REFERENCES    !
!         +----------------------------+
!         !                            !
!         !         REFERENCES         !
!         !       TYPE<1> "TEXT"       !
!         !                            !
!         +============================+
!         !         CODE SIZE          !
!         +----------------------------+
!         !          GLA SIZE          !
!         +----------------------------+
!         !                            !
!         !           OBJECT           !
!         !                            !
!         +----------------------------+
!         !          X'E0E0E0'         !
!         +============================+
!

   %const %integer max defs= 1600
   %const %integer max tags= 1800
   %const %integer max externals= 100

   %const %integer objects= 1
   %const %integer directives= 2
   %const %integer object file= 3

                                         !OBJECT FILE CONTROL CODES

   %const %integer abs code= 1
   %const %integer abs gla= 2
   %const %integer plug code= 3
   %const %integer plug gla= 4
   %const %integer set loc= 5
   %const %integer line no= 6
   %const %integer ext reloc= 7
   %const %integer terminator= 8
                                         !             MOD CODE = 9
                                         !             MOD GLA  = 10
                                         !             MOD REL  = 11

   %recordformat tfm(%integer ca, tag, flags, %record(tfm)%name link)
!NOTIMP80     %recordspec TFM_LINK(TFM)
   %record %format pfm(%integer ca,frame,flags,param)

   %recordformat deffm(%integer ca, uses, %record(deffm)%name link)
!NOTIMP80    %recordspec DEFFM_LINK(DEFFM)


   %own %record (tfm) null; null_ca = -1

   %const %integer long jump bit= 128
   %const %integer load ds= 256
   %const %integer load lnb= 512
   %const %integer marked= 1024
   %const %integer ignore= 2048
   %const %integer invert= 4096
   %const %integer fixed= 8192

   %const %integer cond bit= 32

   %integer current line
   %integer ca,ga
   %own %integer max ca= 0
   %own %integer last event= 0
   %own %integer total ca= 0
   %integer gla limit
   %own %integer tags= 0
   %own %integer top tag= max tags
   %own %string (10) text

   %string (10) %array xtext(1:max externals)
   %byte %integer %array xtype(1:max externals)
   %integer %array xaddr(1:max externals)

   %own %integer xrefs
   %integer j,mask
   %integer pregs
   %integer mod,flags

   %const %byte %integer %array inverted(0:19)= %c
                  9,2,1,6,5,4,3,8,7,0, 19,12,11,16,15,14,13,18,17,10

   %record (deffm) %array def(0:max defs)
   %record (tfm) %array tag(0:max tags+1)

!
   gla limit = 0
   pregs = 0
!
   %routine fail(%string (63) message, %integer n)
      selectoutput(0)
      printstring("*** PASS3 FAILS: ")
      printstring(message)
      write(n,1)
      %if current line#0 %start
         printstring(" AT LINE"); write(current line,1)
      %finish
      newline
      %monitor; %stop
   %end
   %routine get text
      %integer l,j,s
      text = ""
      readch(l)
      %cycle j = 1,1,l
         readch(s)
         text = text.tostring(s) %if j<=10
      %repeat
   %end
   %routine get(%integer %name n)
      %integer s,sh
      readch(s); readch(sh)
      sh = s<<8+sh
      sh = sh!x'FFFF0000' %if sh&x'00008000'#0
      n = sh;                            !TEMP TO PROPAGATE SIGN
   %end
   %routine put(%integer n)
      printch(n&255); printch(n>>8)
   %end
   %routine dump(%integer code,value)
      printch(code); put(value)
   %end
   %routine cdump(%integer code,value)
      printch(code); put(value)
      ca = ca+2
   %end
   %routine gdump(%integer code,value)
      printch(code); put(value)
      ga = ga+2
   %end
   %routine short jump(%integer disp)
      %integer n
      %const %integer nop= k'000240'
!       %constintegerarray BR(0:19) = 8_000400,;   !0: BR
!                                     8_001400,;   !1: BEQ
!                                     8_001000,;   !2: BNE
!                                     8_003000,;   !3: BGT
!                                     8_002000,;   !4: BGE
!                                     8_000000,;   !5: BLT
!                                     8_003400,;   !6: BLE
!                                     8_103400,;   !7: BCS (TRUE)
!                                     8_103000,;   !8: BCC (FALSE)
!                                     8_000000,;   !9: NOP
!                                     8_000400,;   !10: BR
!                                     8_001400,;   !11: BEQ
!                                     8_001000,;   !12: BNE
!                                     8_101000,;   !13: BHI
!                                     8_103000,;   !14: BHIS
!                                     8_103400,;   !15: BLO
!                                     8_101400,;   !16: BLOS
!                                     8_103400,;   !17: BCS (TRUE)
!                                     8_103000,;   !18: BCC (FALSE)
!                                     8_000240 ;   !19: NOP
      %const %integer %array br(0:19)= x'100',
            x'300',x'200',x'600',x'400',x'500',x'700',x'8700',x'8600',
           x'00',x'100',x'300',x'200',x'8200',x'8600',
           x'8700',x'8300',x'8700',x'8600',x'00'
      n = br(mask&31)
      %if n=0 %then n = nop %else n = n+disp&255
      cdump(abs code,n)
      shortjumps = shortjumps+1
   %end

   %routine long jump(%integer dest)
      %if mask#0 %start
         mask = inverted(mask&31)
         %if mask=0 %start
            cdump(abs code,k'000240')
            %return
         %finish
         short jump(2)
         shortjumps = shortjumps-1
         mediumjumps = mediumjumps-1
         longjumps = longjumps+1
      %finish
      medium jumps = medium jumps+1
      cdump(abs code,x'77'); cdump(abs code,dest-ca-2);  ! 8_000167
   %end
   %routine process header(%integer dummy, level, %record(pfm)%name proc)
                                         !DUMMY = 0 TO INHIBIT CODE DUMPING%c
                                         (FIRST TIME)
!NOTIMP80       %recordspec PROC(PFM)
      %integer p,disp,d,flags
      %routine dump(%integer value)
         %if dummy=0 %then mod = mod+2 %else cdump(abs code,value)
      %end
      flags = proc_flags
      %if flags&(\(3<<5))#0 %start
         dump(x'1126');                  ! 8_010446
         dump(x'1166') %if flags&load ds#0;  ! 8_010546
         %if proc_param#0 %start
            dump(x'E5CE'); dump(proc_param);  ! 8_162716
         %finish %else %start
            dump(x'1055') %if flags&(2<<5)#0;  ! 8_010125
            dump(x'1015') %if flags&(3<<5)#0;  ! 8_010025
         %finish
         p = 5; disp = 6; d = b'10000'
         %until disp<0 %cycle
            %if flags&d#0 %start
               %if p=level %start
                  %if disp=0 %start
                     dump(k'010515')
                  %finish %else %start
                     dump(k'010565')
                     dump(disp)
                  %finish
               %finish %else %start
                  %if disp=0 %start
                     dump(x'130D') %if level#1;  ! 8_011415
                  %finish %else %start
                     dump(x'1D35');      ! 8_016465
                     dump(disp); dump(disp)
                  %finish
               %finish
            %finish
            disp = disp-2
            p = p-1
            d = d>>1
         %repeat
         dump(x'1144');                  ! 8_010504
         dump(x'65C5'); dump(proc_frame);  ! 8_062705
      %finish
   %end

   %integer %fn new proc(%integer proc id,level);  !RETURNS USE MASK
      %record (tfm) %name proc
      %record (tfm) %name t,last t
      %record (deffm) %name f
      %record (deffm) %name def list; def list == null
      %integer r,code,n,fix
      %integer proc size
      %integer frame,events
      %integer inner uses,uses
      %integer modified
      %switch d(1:8)

      %routine adjust labels(%integer here,new)
         %record (deffm) %name d
         d == def list
         %cycle
            %return %if d_ca<=here
            d_ca = d_ca+new
            d == d_link
         %repeat
      %end
      %routine mark tags
                                         !LABEL LIST IN DECREASING ORDER OF CA
                                         !THE LABEL LIST IS REVERSED
         %record (deffm) %name l,n
         %record (tfm) %name t
         t == proc_link;                 !HEAD OF REF LIST
         l == def list; def list == null
         %cycle
            %return %if addr(l)=addr(null);  !END OF LABELS
            n == l_link
            l_link == def list
            def list == l
            %cycle
               %exit %if addr(t)=addr(null)
               t_flags = t_flags&(\marked)
               %if t_ca>=l_ca %start
                  t_flags = t_flags!marked
                  %exit
               %finish
               t == t_link
            %repeat
            l == n
         %repeat
      %end

      %routine remove unused labels
                                         !LABEL LIST IS IN INCREASING ORDER OF%c
                                         CA
                                         !AND IS REVERSED
         %record (deffm) %name n,next
         n == def list
         def list == null
         %while addr(n)#addr(null) %cycle
            next == n_link
            %if n_uses#0 %start
               n_link == def list
               def list == n
            %finish
            n == next
         %repeat
      %end

      %routine simplify jumps
                                         !LABEL LIST IN ANY ORDER
         %record (tfm) %name this,next
         %integer mod
         mod = 0
         next == proc_link; %return %if addr(next)=addr(null)
         %cycle
            this == next
            next == next_link; %return %if addr(next)=addr(null)
            next_ca = next_ca+mod
            %if next_flags&(marked!ignore!fixed)=0 %and %c
               this_ca+2=next_ca %and next_tag#0 %and %c
               next_flags&cond bit=0 %start
               %if def(this_tag)_ca=this_ca+4 %start
                  proc size = proc size-2
                  mod = mod-2; modified = 1
                  this_flags = this_flags&(\31)!inverted(this_flags&31)
                  %if this_flags&cond bit=0 %start
                     this_flags = this_flags!long jump bit
                  %finish
                  this_flags = this_flags!invert
                  def(this_tag)_uses = def(this_tag)_uses-1
                  this_tag = next_tag
                  next_flags = ignore!marked
                  adjust labels(next_ca,-2)
                  next == next_link; this_link == next
                  %exit %if addr(next)=addr(null)
                  next_ca = next_ca+mod
               %finish
            %finish
         %repeat
      %end

      %routine defer jumps
                                         !LABEL LIST IN INCREASING ORDER OF CA
         %integer mod,n
         %record (deffm) %name d,l,last
         %record (deffm) head
         %record (tfm) %name t
         t == proc_link; head_link == def list
         %cycle
            mod = 0
            last == head
            %until addr(last)=addr(null) %cycle
               l == last_link
               %exit %if addr(l)=addr(null)
               %cycle
                  %return %if addr(t)=addr(null)
                  %exit %if t_ca>l_ca
                  %if t_ca=l_ca %and t_flags&cond bit=0 %and t_tag#0 %start
                     d == def(t_tag)
                     n = d_ca
                     %if n#l_ca %start
                        mod = 1; modified = 1
                        l_ca = n
                        last_link == l_link
                        l_link == d_link
                        d_link == l
                        def list == head_link
                     %finish
                     %exit
                  %finish
                  t == t_link
               %repeat
               last == last_link
            %repeat
            %return %if mod=0
         %repeat
      %end
      %routine expand(%record(tfm)%name proc)
         %real time
!NOTIMP80        %recordspec PROC(TFM)
         %integer disp,here,new,mask
         %integer modx,returns
         %integer display,level bit
         %record (deffm) %name d
         %record (tfm) %name t,tag head
         %record (pfm) %name procp
         %integer paramx
         time = cputime
         procp == proc

         flags = 0; mod = 0; returns = 0

         paramx = pregs>>2
                                         !CALCULATE SIZE OF ENTRY & EXIT CODE%c
                                         SEQUENCES

         level bit = 1<<(level-1)
         mask = (-1)<<(level)
         display = (inner uses!(uses&(\level bit)))&(\mask)
                                         !LNB DOES NOT NEED TO BE SAVED IF IT%c
                                         IS ONLY USED LOCALLY
         inner uses = (inner uses!uses)&(\mask)

                                         ! events condition added to fix bug%c
                                         by M.T.
         %if EVENTS#0 %or inner uses#0 %or paramx#0 %start;  !NEEDS A DISPLAY
            flags = display!load lnb!(pregs&3)<<5
            flags = flags!load ds %if pregs#0
            returns = 4;                 !EXTRA CODE PER RETURN
         %finish
         tag head == proc_link
         procp_frame = frame
         proc_flags = flags
         procp_param = paramx
         process header(0,level,proc)
         modx = mod

         proc size = proc size+mod+2

                                         !STRETCH JUMPS

         %until mod=0 %cycle
            mod = 0
            t == tag head
            %while addr(t)#addr(null) %cycle
               here = t_ca+mod; t_ca = here
               %if t_tag=0 %start;       !RETURN
                  %if returns#0 %start
                     mod = mod+returns
                     adjust labels(here,returns)
                  %finish
               %finish %else %start
                  %if t_flags&long jump bit=0 %start;  !STILL SHORT
                     disp = def(t_tag)_ca
                     disp = disp-here-2
                     %unless-k'400'<=disp<=k'376' %start
                        t_flags = t_flags!long jump bit
                        new = 2
                        new = 4 %if t_flags&cond bit#0;  !CONDITIONAL
                        mod = mod+new
                        adjust labels(here,new)
                     %finish
                  %finish
               %finish
               t == t_link
            %repeat

            returns = 0
            proc size = proc size+mod
         %repeat

         proc size = proc size+6 %if events#0
         proc size = (proc size+2)&(\2);  !UP TO A MULTIPLE OF 4
         total ca = total ca+proc size
                                         !SPACE FOR EVENT LINK (+ROUND TO *4)
         proc_ca = ca
         def(proc id)_ca = ca
         modx = modx+ca;                 !BIAS FOR HEADER

                                         !ALLOCATE THE LABELS

         d == def list
         %while addr(d)#addr(null) %cycle
            d_ca = d_ca+modx
            d == d_link
         %repeat

         ca = ca+proc size
         stretchtime = stretchtime+(cputime-time)
      %end

      %routine get tag(%integer index)
         tags = tags+1
         fail("TOO MANY JUMPS",tags) %if tags>top tag
         fail("TAG OVERFLOW",index) %if index>max defs
         t == tag(tags)
         get(t_ca)
         t_tag = index
         last t_link == t
         last t == t
         t_link == null
      %end

      fail("PROC OVERFLOW",proc id) %if proc id>max defs
      proc == tag(top tag)
      top tag = top tag-1
      fail("TOO MANY TAGS",top tag) %if toptag<tags
      proc_link == null; last t == proc
      proc_flags = 0; proc_ca = 0; proc_tag = proc id
      inner uses = 0; fix = 0

      %cycle
         readch(code)
         selectoutput(object file)
         ->d(code) %if 0<code<=8
         fail("ILLEGAL DIRECTIVE",code)

d(1):                                    !PROC HEAD

         get(n)
         inner uses = inner uses!new proc(n,level+1)
         ->outd

d(2):                                    !PROC END

         get(proc size);                 !SIZE OF PROC (BASIC)
         get(frame);                     !STATIC FRAME SIZE
         get(events);                    !EVENTS
         get(uses);                      !BASE REG USAGE
         get(pregs);                     !PARAMS IN REGS
         %result = 0 %if proc id=0
         %until modified=0 %cycle
            modified = 0
            remove unused labels;        !LABELS <<<<
            defer jumps
            mark tags;                   !LABELS >>>>
            simplify jumps
         %repeat
         expand(proc);                   !STRETCH JUMPS
         %result = inner uses

d(3):                                    !LABEL DEFINITION

         get(r);                         !TAG
         %if r<0 %start;                 !SWITCH LABEL
            f == def(-r)
            f_uses = f_uses+1;           !IT HAS A HIDDEN USE
            fix = fixed
         %finish %else %start
            fail("TAG OVERFLOW",r) %if r>max defs
            f == def(r)
         %finish
         f_link == def list; def list == f
         get(f_ca)
         ->outd

d(4):                                    !LABEL REFERENCE

         get(r)
         get tag(r)
         readch(t_flags)
         t_flags = t_flags!fix; fix = 0
         def(r)_uses = def(r)_uses+1
         ->outd

d(8):    get(r)
         def(r)_uses = 255
         ->outd
d(5):                                    !RETURN

         get tag(0)
         t_flags = 0
         ->outd

d(6):                                    !LOAD DATA

         readch(r); get(n); get text
         xrefs = xrefs+1
         fail("TOO MANY EXTERNALS",xrefs) %if xrefs>max externals
         xtext(xrefs) = text
         xtype(xrefs) = r
         xaddr(xrefs) = n
         ->outd

d(7):                                    !SPEC USED

         get(n)
         xtype(n) = xtype(n)!8;          !SHOW USED

outd: %repeat
   %end

   %routine process load data

                                         !TYPE BITS:      &1 : 0=PROC, 1=DATA
                                         !                &2 : DEFINITION
                                         !                &4 : REFERENCE (SPEC)
                                         !                &8 : USED      (SPEC)

      %integer j,type
      %integer defs
      %integer refs

      %routine plant(%integer mask)
         %string %name s
         %integer type,j,n
         %return %if xrefs=0
         %cycle j = 1,1,xrefs
            type = xtype(j)
            %if type&mask#0 %start
               put(xaddr(j)) %if mask=2;  !DEFINITION
               printch(type&7)
               s == xtext(j)
               printch(length(s))
               %cycle n = 1,1,length(s)
                  printch(charno(s,n))
               %repeat
            %finish
         %repeat
      %end

                                         !CALCULATE AREA SIZES

      defs = 0
      refs = 0
      %if xrefs#0 %start
         %cycle j = 1,1,xrefs
            type = xtype(j)
            %if type&2#0 %start;         !DEFINITION
               defs = defs+1
               xaddr(j) = def(xaddr(j))_ca %if type&1=0;  !PROC DEF
            %finish %else %start
               %if type&8#0 %start;      !SPEC
                  refs = refs+1
                  xaddr(j) = refs
               %finish
            %finish
         %repeat
      %finish

      put(1);                            !ONE MODULE
      put(defs); plant(2)
      put(refs); plant(8)

   %end

   %routine dump proc(%integer level)
      %switch y(1:16)
      %integer code,index,d,disp,n
      %integer events,ep,from
      %integer old ca
      %record (tfm) %name proc,t
      old ca = ca
      proc == tag(top tag); top tag = top tag-1
      ca = proc_ca
      dump(set loc,ca)
      process header(1,level,proc)

      %cycle
         readch(code)
         ->y(code) %if 0<code<=16
         fail("ILLEGAL OBJECT CODE",code)

y(1):                                    !PROC HEAD

         get(index)
         dump proc(level+1)
         dump(set loc,ca)
         ->outy

y(2):                                    !PROC END

         get(events); get(ep); get(from)
         %if level#1 %start
            %if (ca&2=0 %and events=0) %or (ca&2#0 %and events#0) %start
               cdump(abs code,0);        !ALIGN IT
            %finish
            %if events#0 %start
               cdump(abs code,events)
               printch(9); cdump(abs code,def(from)_ca)
               printch(9); cdump(abs code,def(-ep)_ca)
            %finish
            n = (ca-last event)<<1
            last event = ca
            n = n!1 %if events#0
            n = n!2 %if proc_flags#0
            n = n!4 %if proc_flags&load ds#0
            cdump(abs code,n)
         %finish
         max ca = max ca+ca-proc_ca
         ca = old ca
         %return

y(9):                                    !RETURN

         tags = tags+1
         %if proc_flags#0 %start
            %if proc_flags&load ds#0 %start
               cdump(abs code,x'1585');  !*MOV_(SP)+,DS  8_012605
            %finish %else %start
               cdump(abs code,x'1105');  !*MOV_LNB,DS   8_010405
            %finish
            cdump(abs code,x'1584');     !*MOV_(SP)+,LNB   8_012604
         %finish
         ->outy

y(7):                                    !JUMP

         tags = tags+1; t == tag(tags)
         get(index); readch(mask)
         ->outy %if t_flags&ignore#0
         %if t_flags&invert#0 %start
            index = t_tag
            mask = t_flags&31
         %finish %else %start
            fail("MISMATCH",index) %if t_tag#index
         %finish
         d = def(index)_ca
         disp = d-ca-2
         %if-k'400'<=disp<=k'376' %then short jump(disp//2) %else long jump(d)
         ->outy

y(3):                                    !ABSOLUTE CODE

         get(n); cdump(abs code,n); ->outy

y(8):                                    !LABEL CODE

         get(n); cdump(abs code,def(n)_ca); ->outy

y(4):                                    !ABSOLUTE GLA

         get(n)
         gdump(abs gla,n)
         ->outy

y(6):                                    !MODIFY GLA

         get(index); get(n)
         dump(plug gla,def(index)_ca); put(n)
         ->outy

y(11):                                   !MOD CODE
y(12):                                   !MOD GLA
y(13):                                   !MOD REL

         printch(code-2); ->outy

y(14):                                   !MOD EXT

         get(index); dump(ext reloc,xaddr(index)); ->outy

y(15):   ;                               ! MCODE BRANCH
y(16):   ;                               ! MCODE SOB
         get(n); get(index)
         d = def(index)_ca
         disp = (d-ca-2)//2
         %if code=15 %start
            fail("BRANCH LENGTH",disp) %unless-k'200'<=disp<=k'177'
            n = n!disp&255
         %finish %else %start
            fail("FORWARD SOB",disp) %if disp>0
            disp = -disp
            fail("SOB LENGTH",disp) %if disp>63
            n = n!disp
         %finish
         cdump(abscode,n)
         ->outy

y(10):                                   !LINE FLAG

         get(current line)
         dump(lineno,current line)

outy: %repeat
   %end

   current line = 0
   %cycle j = 0,1,maxdefs
      def(j) = 0
   %repeat
   tag(0) = 0; tag(max tags+1) = 0

   selectoutput(object file)
   selectinput(directives)

   ca = 0; total ca = 0; j = new proc(0,1); get(gla limit)

   process load data

   selectinput(objects)
   put(total ca); put(gla limit)

   top tag = max tags
   tags = 0
   ca = 0; ga = 0; last event = -2
   dump proc(1)
   dump(terminator,last event)
   printch(x'E0'); put(x'E0E0')

   fail("STRETCH ERROR",max ca-total ca) %if max ca#total ca

   selectoutput(0)

   printstring("Code"); write(max ca,1)
   printstring("   glap"); write(ga,1)
   printstring(":   total ="); write(max ca+ga,1)
   printstring(" bytes"); newline
%end
%end %of %file