{#######################################}
             {#  PDP11 IMP77 Object File Generator  #}
             {#                                     #}
             {#       Copyright November 1981       #}
             {#          Peter S. Robertson         #}
             {#                                     #}
             {#######################################}


{#################################################################}
{# Object file format:   <N> = Word value N,  [N] = Byte value N #}
{#                                                               #}
{#        Zeroth word: <Link>  0 or size in bytes of Data Items  #}
{#         First word: <Size of code area>                       #}
{#        Second word: <Size of gla area>                        #}
{#         Third word: <Size of diag table area>                 #}
{#        Fourth word: <Size of line number table area>          #}
{#         Fifth word: <Size of event block>                     #}
{#                     "Section name"                            #}
{#                     <Number of external definitions>          #}
{#                     External Definitions                      #}
{#                     [Area] <Displacement> "REFERENCE"         #}
{#                     <Number of external references>           #}
{#                     "REFERENCE"                               #}
{#                     External References                       #}
{#                                                               #}
{#                     Data Items                                #}
{#                                                               #}
{#      Item  1:  <N>  Select code area at displacement <N>      #}
{#      Item  2:  <N>  Select gla  area at displacement <N>      #}
{#      Item  3:  <N>  Select diag area at displacement <N>      #}
{#      Item  4:  <N>  Select line area at displacement <N>      #}
{#      Item  5:       Relocate by code area base                #}
{#      Item  6:       Relocate by  gla area base                #}
{#      Item  7:       Relocate by diag area base                #}
{#      Item  8:       Relocate by line area base                #}
{#      Item  9:  <N>  Relocate by external <N>                  #}
{#      Item 10:       Relocate by -PC                           #}
{#      Item 11:  [B]  Add byte [B] to current area              #}
{#      Item 12:  <W>  Add word <W> to current area - aligned!   #}
{#      Item 13:  <N>  This is line <N>                          #}
{#      Item 14:       Event Block <Mask><Ep><Low><High>         #}
{#      Item 15:       End of file                               #}
{#################################################################}

%constinteger  Select Code =  1,
               Select Gla  =  2,
               Select Diag =  3,
               Select Line =  4,
               Code Reloc  =  5,
                Gla Reloc  =  6,
               Diag Reloc  =  7,
               Line Reloc  =  8,
                Ext Reloc  =  9,
                 Pc Reloc  = 10,
               Add Byte    = 11,
               Add Word    = 12,
               Line No     = 13,
               Event Block = 14,
               Eof         = 15

{Configuration constants}

%constinteger Max Item      = 8000,
              Max External  =  200,
              X Length      =   15,
              Objectives    =    1,
              Directives    =    2,
              Object        =    3

%externalstring(63)%fnspec usual ItoS %alias "S#ITOS" (%integer N)

%begin
%stringfn itos(%integer a, b)
   %result=usual itos(a)
%end {itos}

{Block attributes}

   %constinteger Attr R1          = 1<< 8,
                 Attr R2          = 1<< 9,
                 Attr Inner Uses  = 1<<10,
                 Attr Uses locals = 1<<11,
                 Attr Dynamic     = 1<<12,
                 Attr String      = 1<<13

  %recordformat Itemfm( %c
      (%byte Type, Flags %or %integer Dummy  %or %integer Frame %or %c
                             %integer String %or %integer Entry1),
      (%integer Ca %or %record(Itemfm)%name First %or %integer Attr %c
                   %or %integer Entry2),
      (%record(Itemfm)%name Label %or %record(Itemfm)%name Second %c
                                  %or %integer Params),
      %record(Itemfm)%name Link)

{*   %recordformat Itemfm( %c
{*       (%byte Type, Flags, %integer Ca, %record(Itemfm)%name Label, Link) %c
{*   %or (%integer Dummy, %record(Itemfm)%name First, Second)               %c
{*   %or (%integer Frame, Attr, Params)                                     %c
{*   %or (%integer String)                                                  %c
{*   %or (%integer Entry1, Entry2))

   {   *------*-------*---------*--------*--------*
   {   | Type | Flags |    Ca   |  Label |  Link  |
   {   *------*-------+---------+--------*--------*
   {                  |  First  | Second |
   {   *--------------+---------*--------*
   {   |    Frame     |   Attr  | Params |
   {   *--------------*---------*--------*
   {   |    String    |
   {   *--------------*---------*
   {   |   Entry 1    | Entry 2 |
   {   *--------------*---------*

                  {Types}         {Flags}

   %constinteger  Lab     =  0,   Long    = 1<<0,
                  Slab    =  1,   Invert  = 1<<1,
                  McUsed  =  2,   Removed = 1<<2,
                  Return  =  3,   Unreach = 1<<3,
                  EndJ    =  4,   Forward = 1<<4,
                  Call    =  5,
                  CallP1  =  6,
                  CallP2  =  7,
                  JumpC   =  8,
                  JumpP1  =  9,
                  JumpP2  = 10,
                  Uncond  = 11,
                  CjumpC  = 12,
                  CjumpP1 = 13,
                  CjumpP2 = 14,
                  Cond    = 15,
                  OldLab  = 16,
                  Prefix  = 17

   {                    label link
   {      *-----*------*-----*----*        *-------*------*-------*---*
   { Z--> | lab | size |  *  |  *-+------> | frame | attr | param | * |
   {      *-----*------*--+--*----*        *-------*------*-------*-+-*
   {                      |                                         |
   {                      |                                         v
   {                      v                *-------*------*-------*---*
   {              Labels & Defs            |string |      |       | * |
   {                                       *-------*------*-------*-+-*
   {                                                                |
   {                                                                v
   {                                                        Next block

   %integer More
   %constinteger SpMove = 2
   %integer Events, Event Count
   %ownstring(15) Section = "", New Section = ""
   %owninteger             Xmin      = Max External+1,
                           Xmax      = 6,
                           Xnum      = 0,
                           Spec List = 0
   %ownintegername         Spec End
   %string(X Length)%array Xspec(2:Max External)
   %integerarray           Xused, Xmap(2:Max External)
   %constrecord(Itemfm)%name Null = 0
   %record(Itemfm)%array    Item(0:Max Item)

        {*----------------*------------*-------------------*}
        {|  (labels) Max->|\\\\\\\\\\\\|<-Min (references) |}
        {*----------------*------------*-------------------*}

   %ownrecord(Itemfm)%name Z, Pitem, Parm List, Order
   %record(Itemfm) Dummy
   %integer Min, Max
   %integer Total Ca, This Line
   %integer Constant Size,
            Own Size

!!!   %routine Tell(%string(63) What)
!!!      Printstring(What)
!!!      Newline
!!!   %end
   %routine Fail(%string(63) Why)
      Select Output(0)
      Printstring("*Pass 3 fails -- ")
      Printstring(Why)
      %if This Line # 0 %start
         Printstring(" at source line")
         Write(This Line, 1)
      %finish
      Newline
      %monitor
      %stop
   %end
   %integerfn Two Bytes
      %integer Bl, Bh
      Readch(Bl)
      Readch(Bh)
      %result = Bh<<8+Bl
   %end
   %integerfn Two signed Bytes
      %integer N
      N = Two bytes
      N = N!x'FFFF0000' %if N&x'8000' # 0
      %result = N
   %end
   %routine Get Text(%string(*)%name Text)
      %integer j, l ,s
      Text = ""
      Readch(L)
      %for J = 1,1,L %cycle
         Readch(S);  S = S-32 %if 'a' <= S <= 'z'
         Text = Text.Tostring(S)
      %repeat
   %end

   %routine Mark Use(%integer N)
      Fail("Spec out of range") %unless 0 < N <= Xmax
      %if Xmap(N) = 0 %start
         Spec End = N
         Spec End == Xused(N)
         Xnum = Xnum+1
         Xmap(N) = Xnum
      %finish
   %end
   %routine Get Pitem(%integer Tag, Use)
      %record(Itemfm)%name Lab, X, Y
      Lab == Item(Tag)
      Pitem == Parm List
      %while Pitem ## Null %cycle
         %return %if Pitem_Label_Label == Lab
         Pitem == Pitem_Link
      %repeat
                        Y == Item(Use);  Y     = 0
      Use = Use-1;      X == Item(Use);  X     = 0
      Use = Use-1;  Pitem == Item(Use);  Pitem = 0
          Y_Link == X;  Y_Type = Prefix;  Y_Label == Lab
                        X_Type = Prefix;  X_Label == Lab
      Pitem_Label == Y
      Pitem_Link  == Parm List
      Parm List   == Pitem
   %end
   %routine Process(%record(Itemfm)%name Head)
      %integer Mark
      %record(Itemfm) Hold
      %record(Itemfm)%name P, Next, End, T
      %integer Here, There, Mod, N, Old Ca, Changed, Attr
      %integername Size

      Mark = 0                        {where all labels start}
      %if Head_Label == Null %start
         min = min-1; fail("Tables Full") %if min = max
         %return
      %finish

      Size == Head_Ca
      Attr = Head_Link_Attr
      Hold = 0
      %cycle
         Changed = 0

         {First conflate jumps to jumps and mark used labels}

         P == Head_Label;  %return %if P == Null
         Mark = (Mark+1)&127     {NB:  bit 128 zero}
         %cycle
            %if P_Type = Uncond %or P_Type = Cond %start   {a jump}
               Next == P_Label_Link                        {item after label}
               %if Next ## Null %start                     {not at the end}
                  %if Next_Ca = P_Label_Ca %start          {labelled item}
                     %if Next_Type = Uncond %and Next_Label ## P_Label %start         {it's unconditional}
                        P_Label == Next_Label              {go directly}
                        Changed = 1
                        !!!Tell("Jump to jump")
                     %finish %else %if Attr&Attr Dynamic  = 0      %and %c
                                       Next_Type = Return %and %c
                                       P_Type    = Uncond %start
                        P_Label == Dummy
                        P_Type  = Return
                        Changed = 1
                        !!!Tell("Jump to return")
                     %finish
                  %finish
               %finish
               P_Label_Flags <- Mark                       {mark the actual label}
            %finish %else %start
               P_Label_Flags <- Mark %if P_Type = Mc Used
            %finish
            P == P_Link
         %repeat %until P == Null

         {Next remove unreachable code and unused labels}

         P   == Head_Label
         End == Hold
         Mod = 0
         %while P ## Null %cycle
            P_Ca = P_Ca+Mod
            End_Link == P
            %if P_Type = Lab %start
               %if P_Flags = Mark %start
                  End == P                         {used, so back on the list}
               %finish %else %start
                  P_Type = OldLab
                  !!!Tell("Unused label")
               %finish
               P == P_Link
               %continue
            %finish
            End == P                               {put it back on}
            %if P_Type = Uncond %or P_Type = Return %start
               P_Flags = P_Flags!Unreach
               Here = P_Ca+2                       {past the jump}
               %cycle
                  P == P_Link
                  %exit %if P == Null
                  %if P_Type <= Slab %start
                     %exit %if P_Type = Slab %or P_Flags = Mark
                     P_Type = Old Lab
                  %finish
                  P_Flags = Removed
               %repeat
               %if P == Null %then There = Size %else There = P_Ca
               N = (Here-There-Mod)
               Mod = Mod+N
               !!!Tell("Unreachable code".ItoS(N, 1)) %if N # 0
            %finish %else %if Attr&255 = 0      %and %c
                     Call <= P_Type <= CallP2   %and %c
                                P_Link ## Null  %and %c
                           P_Link_Type = Return %and %c
                         P_Link_Ca+Mod = P_Ca+2 %start
               P_Type = P_Type+3
               P_Link_Flags = Removed
               P_Link == P_Link_Link
               P == P_Link
               Mod = Mod-2
               !!!Tell("Jcall")
            %finish %else %start
               P == P_Link
            %finish
         %repeat
         End_Link   == Null
         Head_Label == Hold_Link
         Size = Size+Mod
         Changed = Changed!Mod

         {Finally, invert jumps round jumps}

         Mod = 0
         End == Hold
         P == Head_Label
         %while P ## Null %cycle
            End_Link == P
            Old Ca = P_Ca
            P_Ca = P_Ca+Mod
            %if P_Type = Cond %start                           {a jump}
               %if P_Link ## Null %start
                  Next == P_Link                               {next item}
                  %if Jumpc <= Next_Type <= Uncond %and %c
                      Next_Ca+Mod = P_Ca+2 %start      {adjacent}
                     %if P_Label_Ca = Next_Ca+2 %start
                        Next_Flags = Removed              {invert the condition}
                        P_Type = Next_Type+4              {onto conditional var}
                        P_Flags = P_Flags!!Invert
                        P_Label == Next_Label
                        P_Link == Next_Link               {Remove Next}
                        Mod = Mod-2
                        !!!Tell("Jump inverted")
                     %finish
                  %finish
               %finish
            %finish
            End == P
            P == P_Link
         %repeat
         End_Link   == Null
         Head_Label == Hold_Link
         Size = Size+Mod
         Changed = Changed!Mod
      %repeat %until Changed = 0

      Min = Min-1;  Fail("Tables full") %if Min = Max
      %if JumpC <= End_Type <= JumpP2 %start   {final jump to procedure}
         T == Item(Min)
         T_Type = EndJ
         T_Link   == Order;  Order == T
         T_Second == End                  {end jump}
         T_First  == Head                 {this block}
         !!!Tell("End jump")
      %finish
   %end
   %routine Phase 1(%integer Head Tag)  {Input directives and build connections}
      %switch D(1:25)
      %integer Sym, Tag, N, Ca, Attr, Fcode
      %integer Lb, Ub
      %record(Itemfm)%name Refs, Head, T, B, Bx, Q
      %record(Itemfm) Hold
      Refs == Hold
      Head == Item(Head Tag);  Head_Type = Lab
      Min = Min-1;  B  == Item(Min)
      Min = Min-1;  Bx == Item(Min);  Bx_Ca = 0
      Head_Link == B
         B_Link == Bx
        Bx_Link == Z
              Z == Head

      %cycle
         Readch(Sym)
         ->D(Sym) %if 1 <= Sym <= 25
D(*):    Fail("Unknown directive ".ItoS(Sym, 0))

D(16):   {Entry 1}
D(17):   {Entry 2}

         N = Two Bytes
         Lb <- Two signed Bytes;  Ub <- Two signed Bytes
         Max = Ub %if Ub > Max
         Get Pitem(Lb, Ub)
         %if Sym = 16 %start
            Pitem_Entry1 = N
         %finish %else %start
            Pitem_Entry2 = N
         %finish
         %continue

D(12):   {Xdef:               <<Tag>> "Id"}
D(13):   {Ddef:               <<N>>   "Id"}

         XMin = XMin-1
         Fail("Too many externals") %if Xmin = Xmax
         Xmap(Xmin)  = Two Bytes
         Xused(Xmin) = Sym-12+Code Reloc
         Get Text(Xspec(Xmin))
         %continue

D(10):   {Notex:              <<N>> "Id"}

         Xmax = Xmax+1
         Fail("Too many external specs") %if Xmax = Xmin
         Fail("Spec mismatch") %if Xmax # Two Bytes>>1
         Get Text(Xspec(Xmax))
         Xused(Xmax) = 0
         Xmap(Xmax)  = 0
         %continue

D(8):    {Spec:               <<N>>}

         Mark Use(Two Bytes>>1)
         %continue

D(1):    {Unconditional Jump: <<Tag>> <<Ca>>}  Sym = Uncond;  ->Common
D(2):    {  Conditional Jump: <<Tag>> <<Ca>>}  Sym = Cond;    ->Common
D(4):    {Procedure Return:   <<000>> <<Ca>>}  Sym = Return;  ->Common
D(14):   {Mc Used:            <<Tag>> <<Ca>>}  Sym = McUsed;  ->Common
D(20):   {Call:               <<Tag>> <<Ca>>}  Sym = Call;    ->Common
D(21):   {Call prefix 1:      <<Tag>> <<Ca>>}  Sym = CallP1;  ->Common
D(22):   {Call prefix 2:      <<Tag>> <<Ca>>}  Sym = CallP2;  ->Common
D(23):   {JumpC:              <<Tag>> <<Ca>>}  Sym = JumpC;   ->Common
D(24):   {JumpP1:             <<Tag>> <<Ca>>}  Sym = JumpP1;  ->Common
D(25):   {JumpP2:             <<Tag>> <<Ca>>}  Sym = JumpP2;  ->Common

Common:  Tag = Two Bytes
         Min = Min-1
         Max = Tag %if Tag > Max
         Fail("Jump tables full") %if Min <= Max
         T == Item(Min)
         T_Ca = Two Bytes
         T_Label == Item(Tag)         {redundant in the case of return}
         T_Flags = 0
         T_Type  = Sym
         Refs_Link == T
         Refs      == T   {add to end of item list}
         %continue

D(19):   {Switch: <<LB>> <<UB>> <<Tag>>}

         Lb <- Two Signed Bytes
         Ub <- Two Signed Bytes
         Tag = Two Bytes
         %for N = Lb, 1, Ub %cycle
            Tag = Tag+1
            T == Item(Tag)
            T = 0
            T_Type = Lab;  T_Ca = N<<1+1  {ODD to give error}
         %repeat
         Max = Tag %if Tag > Max
         %continue

D(18):   {Slab}
D(5):    {Tag definition:  <<Tag>> <<Ca>>}

         Tag = Two Bytes;  Ca = Two Bytes
         Max = Tag %if Tag > Max
         Fail("Label tables full") %if Min <= Max
         T == Item(Tag)
         T_Ca   = Ca
         %if Sym = 18 %start
            %if T_Type # 0 %start      {redefinition}
              N = T_Type %and Fail("Corrupt switch") %if T_Type # Slab
               Refs_Link == Null
               Q == Hold
               %cycle
                  Fail("Switch def error") %if Q == Null
                  %exit %if Q_Link == T
                  Q == Q_Link
               %repeat
               Q_Link == T_Link
               Refs == Q %if Refs == T     {on the end}
            %finish
            T_Type = Slab
         %finish %else %start
            T_Type = Lab
         %finish
         Refs_Link == T;  Refs == T;   {add to end of item list}
         %continue

D(6):    {Start of block:  <<Tag>>}

         Phase 1(Two Bytes)
         %continue

      %repeat

D(7): {End of block:    <<Frame>><<Parameters>><<Sparam>><<Attributes>><<Size>>

      B_Frame   = Two Bytes
      B_Params  = Two Bytes
      Bx_String = Two Bytes
      B_Attr    = Two Bytes
      Head_Ca   = Two Bytes

      Fail("Odd initial size") %if Head_Ca&1 # 0 %or B_Attr&255 # 0

      %if Head Tag = 0 %start
         Bx = 0
         B  = 0
         B_Link == Bx
      %finish
      Mark Use(SPMOVE) %if Bx_String # 0
      Attr = B_Attr
      N = 0
      N = N+2 %if Attr&Attr R1 # 0
      N = N+2 %if Attr&Attr R2 # 0
      B_Frame = B_Frame-B_Params
      B_Params= B_Params-N-Bx_String
      Fcode = 0
      %if B_Frame # 0 %start
         %if B_Frame <= 4 %then Fcode = 2 %else Fcode = 4
      %finish
      %if Attr&(Attr Uses locals!Attr Inner Uses) = 0 %start
         Fcode   = 0
         N       = 0
         B_Frame = 0
         Attr    = 0
      %finish %else %if Attr&Attr Dynamic = 0 %start
         Fcode   = 0
         B_Frame = 0
         N = N+2 %if Attr&Attr R2 # 0
         Attr = Attr&(\Attr Inner Uses)
         !!!Tell("Non-dynamic")
      %finish %else %start
         N = N+4
      %finish
      N = N+4 %if B_Params # 0
      N = N+6 %if Bx_String # 0
      N = N+8 %if Attr&Attr Inner Uses # 0
      B_Attr = Attr+N+Fcode

      Refs_Link == Null
      Head_Label == Hold_Link

      Process(Head)
   %end {of Phase 1}

   %routine Process Parameters
      %integer Extra
      %record(Itemfm)%name P, L, Next, H, L1, L2
      P == Parm List
      %while P ## Null %cycle
         L1   == P_Label
         L2   == L1_Link
         Next == P_Link
         H == L1_Label                         {Block head}
         L == H_Link_Link                      {BX}
         L2_Link == H_Label;  L2_Type = Lab
         L1_Link == L2;       L1_Type = Lab
         H_Label == L1
         L_Label == P
         Extra = 0
         %if P_Entry1 # 0 %start
            Extra = 2
            Extra = 4       %unless P_Entry1 = 1 %or P_Entry1 = x'FFFF'
         %finish
         L1_Ca = -Extra
         %if P_Entry2 # 0 %start
            Extra = Extra+2
            Extra = Extra+2 %unless P_Entry2 = 1 %or P_Entry2 = x'FFFF'
         %finish
         L2_Ca = -Extra
         L_Ca = Extra    {size of prefix}
         P == Next
      %repeat
   %end

   %routine Phase 2   {Minimise the connections}
                      {Note: Refs are in increasing order of CA}
      %record(Itemfm)%name Head, P, End
      %record(Itemfm) All
      %integer Ca

      %routine Stretch(%record(Itemfm)%name Head, %integer Attr)
         %record(Itemfm)%name P, End, Old End, Ll
         %record(Itemfm) Hold
         %integer Mod, N, Old
         Mod = Attr&255
         Fail("Odd mod") %if Mod&1 # 0
         %cycle
            P == Head_Label
            End == Hold
            %while P ## Null %cycle
               Old End == End
               End_Link == P;  End == P              {insert it provisionally}
               P_Ca = P_Ca+Mod
                  %if P_Type = Uncond %start          {unconditional jump}
                     N = P_Label_Ca-(P_Ca+2)
                     N = N+Mod %if P_Flags&Forward # 0 {forward ref}
                     %unless -256 <= N <= 254 %start  {must be long}
                        P_Flags = P_Flags!Long
                        Mod = Mod+2
                        End == Old End                {remove it}
                     %finish %else %if N = 0 %start   {degenerate jump}
                        P_Flags = P_Flags!Removed
                        End == Old End
                        Mod = Mod-2
                        !!!Tell("Degenerate jump removed")
                     %finish
                  %finish %else %if P_Type = Cond %start {conditional jump}
                     N = P_Label_Ca-(P_Ca+2)
                     N = N+Mod %if P_Flags&Forward # 0  {forward ref}
                     %unless -256 <= N <= 254 %start  {must be very long}
                        P_Flags = P_Flags!Long
                        Mod = Mod+4
                        End == Old End                {remove it}
                     %finish %else %if N = 0 %start   {degenerate jump}
                        P_Flags = P_Flags!Removed
                        End == Old End
                        Mod = Mod-2
                        !!!Tell("Degenerate jump removed")
                     %finish
                  %finish %else %if Call <= P_Type <= CallP2 %start      {call}
                     P_Flags = P_Flags!Long
                     Mod = Mod+2                      {calls start short}
                     End == Old End                   {always remove it}
                  %finish %else %if P_Type = Return %start           {return}
                     %if Attr&255 # 0 %and Attr&Attr Dynamic # 0 %start
                        Mod = Mod+4
                        Mod = Mod+4 %if Attr&Attr Inner Uses # 0
                     %finish
                     End == Old End                   {always remove it}
                  %finish
               P == P_Link
            %repeat
            End_Link   == Null
            Head_Label == Hold_Link
            %exit %if Mod = 0
            Head_Ca = Head_Ca+Mod
            Mod = 0
         %repeat
      %end

      {Reorder the blocks if any gain is to be had}

      %routine Reorder Blocks
         %record(Itemfm)%name End, P, First, Second, Next, Loop, N
         %record(Itemfm) Total, Hold
         %integer Again

         {Mark significant blocks}

         End == Hold
         P == Order
         %cycle
            First  == P_First
            Second == P_Second_Label
            Second == Second_Label %if Second_Type = Prefix
            %if Second ## First %start            {beware of recursive ends}
               End_Link == P                      {back on the list}
               End      == P
               P_Second == Second
               Second_Ca = Second_Ca!1
               First_Ca  = First_Ca!1
            %finish
            P == P_Link
         %repeat %until P == Null
         End_Link == Null
         Order    == Hold_Link
         %return %if Order == Null

         {Pull off normal blocks}

         P   == Z
         End == Total
         %while P ## Null %cycle
            Next == P_Link_Link
            %if P_Ca&1 = 0 %start
               End_Link == P
               End      == Next
            %finish
            P == Next_Link
         %repeat

         {Sort the order list - nasty if mutual recursion about}

         %cycle
            Hold_Link == Null
            Again = 0
            %cycle
               Next   == Order_Link
               First  == Order_First
               Second == Order_Second
               Fail("Corrupt order") %if  First_Ca&1 = 0 %or Second_Ca&1 = 0
               P == Hold
               %cycle
                  N == P_Link
                  %exit %if N == Null                    {put it on the end}
                  %if Second == N_First %start           {a better position}
                     Loop == N
                     %cycle
                        %exit %if Loop_Second == First   {loop detected}
                        Loop == Loop_Link
                     %repeat %until Loop == Null
                     %if Loop == Null %start             {no loop}
                        Again = 1                        {reorder it}
                        %exit
                     %finish
                  %finish
                  P == N
               %repeat
               P_Link == Order;  Order_Link == N
               Order == Next
            %repeat %until Order == Null
            Order == Hold_Link
         %repeat %until Again = 0

         {finally insert the blocks in the best positions}

         %cycle
            First  == Order_First
            Second == Order_Second
            %if First_Ca&1 # 0 %start      {not yet placed}
               First_Ca = First_Ca-1
               End_Link == First
               End      == First_Link_Link
            %finish
            %if Second_Ca&1 # 0 %start
               Second_Ca = Second_Ca-1
               End_Link == Second
               End      == Second_Link_Link
            %finish
            Order == Order_Link
         %repeat %until Order == Null
         End_Link == Null
         Z == Total_Link
         !!!Tell("Reordered")
      %end

      Reorder Blocks %if Order ## Null

      {Mark the forward references}

      %routine Mark Forward(%record(itemfm)%name P)
         %while p ## Null %cycle
            %if P_Type = Cond %or P_Type = Uncond %start
               P_Flags = P_Flags!Forward %if P_Ca < P_Label_Ca
            %finish
            P == P_Link
         %repeat
      %end

      Head == Z
      %cycle
         Mark Forward(Head_Label)
         Head == Head_Link_link_Link
      %repeat %until Head == Null

      {Now stretch each block on its own}

      Head == Z
      %cycle
         Stretch(Head, Head_Link_Attr)
         Head == Head_Link_Link_Link
      %repeat %until Head == Null

      Process Parameters   {deal with prefix modification}

      {Combine & allocate the blocks and stretch the whole program}

      %routine Append(%record(Itemfm)%name H)
         %record(Itemfm)%name P
         %integer Pextra, Total
         Pextra = H_Link_Link_Ca
         Ca = Ca+Pextra                {extra for parameters}
         Total = H_Ca
         H_Ca  = Ca
         P == H_Label
         End_Link == H
         End      == H
         H_Label  == H_Link
         %while P ## Null %cycle
            %if JumpC <= P_Type <= JumpP2 %start
               P_Type = Uncond
            %finish %else %if CjumpC <= P_Type <= CjumpP2 %start
               P_Type = Cond
            %finish
            P_Ca = P_Ca+Ca
            End_Link == P
            End      == P
            P == P_Link
         %repeat
         Ca = Ca+Total
         Fail("Odd code address") %if Ca&1 # 0
      %end

      Ca = 0
      All = 0
      End  == All
      Head == Z
      %cycle
         P == Head_Link_Link
         Append(Head)
         Head == P_Link
      %repeat %until Head == Null

      End_Link  == Null
      All_Label == All_Link
      All_Ca = Ca               {total size}
      Stretch(All, 0)
      Total Ca = All_Ca
   %end

   %routine Phase 3(%integer Head Tag, Level)     {Input object, generate file}
      %constintegerarray Branch(0:19) =
            8_000240, {NOP}
            8_001400, {BEQ}  8_002400, {BLT}  8_003400, {BLE}
            8_003000, {BGT}  8_002000, {BGE}  8_001000, {BNE}
            8_000400, {BR}   8_103400, {BCS}  8_103000, {BCC}
            8_000400, {BR}
            8_001400, {BEQ}  8_103400, {BLO}  8_101400, {BLOS}
            8_101000, {BHI}  8_103000, {BHIS} 8_001000, {BNE}
            8_000400, {BR}   8_103400, {BCS}  8_103000  {BCC}

      %constbytearray Inverted(0:19) = 7, 6, 5, 4, 3, 2, 1, 0, 9, 8,
                                      17,16,15,14,13,12,11,10,19,18

      %integer Sym, N, Cc, Attr, X, Bias
      %integer Lb, Ub
      %integer Unreachable
      %integername Ca
      %owninteger Gla Base = 0, Constant Base = 0, Display Reloc = 0
      %integer Code Base
      %record(Itemfm)%name T, B, Bx, Head, Ot
      %switch C(31:54)

         %routine Put(%integer V)
            Printch(V&255)
            Printch(V>>8)
         %end
         %routine Dump1(%integer B)
            %return %if Unreachable # 0
            Printch(Add Byte)
            Printch(B)
            Ca = Ca+1
         %end
         %routine Dump2(%integer V)
            %return %if Unreachable # 0
            Printch(Add Word)
            Printch(V&255)
            Printch(V>>8)
            Ca = Ca+2
         %end
         %routine Set loc(%integer Area)
            Printch(Area)
            Put(Ca)
         %end
         %routine X Reloc(%integer N)
            Fail("Zero relocation") %if N = 0
            N = Xmap(N)
            Fail("External omitted") %if N = 0
            Printch(Ext Reloc);  Put(N)
         %end
         %routine Dump Header(%record(Itemfm)%name B)
            %record(Itemfm)%name V
            %integer String
            %routine Insert(%integer R, N)
               %if N = 1 %start
                  Dump2(8_005200+R)    {INC_R}
               %finish %else %if N = x'FFFF' %start
                  Dump2(8_005300+R)    {DEC_R}
               %finish %else %if N # 0 %start
                  Dump2(8_062700+R)    {ADD_#N,R}
                  Dump2(N)
               %finish
            %end
            V == B_Link
            %if V_Ca # 0 %start
               Ca = Ca-V_Ca
               Set Loc(Select Code)
               V == V_Label
               Insert(2, V_Entry2)
               Insert(1, V_Entry1)
            %finish
            %return %if Attr = 0
            %if Attr&Attr Dynamic # 0 %start
               Dump2(8_010446)                     {MOV_LNB,-(SP)}
               Dump2(8_010504)                     {MOV_DS,LNB}
               %if B_Params # 0 %start
                  Dump2(8_162704)                  {SUB_#P,LNB}
                  Dump2(B_Params)
               %finish %else %start
                  %if Attr&Attr R1 # 0 %start
                     Dump2(8_010125)               {MOV_R1,(DS)+}
                     %if Attr&Attr R2 # 0 %start
                        Dump2(8_010225)            {MOV_R2,(DS)+}
                     %finish
                  %finish
               %finish
            %finish %else %start                   {no dynamic}
               %if B_Params # 0 %start
                  Dump2(8_162705)                  {SUB_#P,DS}
                  Dump2(B_Params)
               %finish %else %if Attr&Attr R1 # 0 %start
                  Dump2(8_010115)                  {MOV_R1,(DS)}
                  %if Attr&Attr R2 # 0 %start
                     Dump2(8_010265)               {MOV_R2,2(DS)}
                     Dump2(2)
                  %finish
               %finish
            %finish
            %if Attr&Attr Inner Uses # 0 %start
               Dump2(8_013746)                  {MOV_Display[Level],-(SP)}
               X Reloc(Display Reloc)
               Dump2(Level*2)
               Dump2(8_010437)                  {MOV_LNB,Display[Level]}
               X Reloc(Display Reloc)
               Dump2(Level*2)
            %finish
            String = B_Link_String
            %if String # 0 %start            {final string parameter}
               Dump2(8_004737)                  {Jsr_@#SpMove}
               X Reloc(SPMOVE)
               Dump2(0)
               Dump2(String)
            %finish
            %if B_Frame # 0 %start
               %if B_Frame = 2 %start
                  Dump2(8_005725)               {TST_(DS)+}
               %finish %else %if B_Frame = 4 %start
                  Dump2(8_022525)               {CMP_(DS)+,(DS)+}
               %finish %else %start
                  Dump2(8_062705)               {Add_#F,DS}
                  Dump2(B_Frame)
               %finish
            %finish
         %end
         %routine Dump Return(%record(Itemfm)%name B)
            %integer Attr
            %return %if Unreachable # 0
            Attr = B_Attr
            %if Attr&255 # 0 %and Attr&Attr Dynamic # 0 %start
               Dump2(8_010405)                  {MOV_LNB,DS}
               %if Attr&Attr Inner Uses # 0 %start
                  Dump2(8_012637)               {MOV_(SP)+,Display[Level]}
                  X Reloc(Display Reloc)
                  Dump2(Level*2)
               %finish
               Dump2(8_012604)                  {MOV_(SP)+,DS}
            %finish
            Dump2(8_000207)                     {RTS_PC}
         %end
         %routine Put String(%string(*)%name S)
            %integer L, J
            L = Length(S)
            Printch(L)
            Printch(Charno(S, J)) %for J = 1, 1, L
         %end
         %routine Put Text(%integer P)
            Put String(Xspec(P))
         %end
         %routine Dump External Definitions
            %integer N, C
            Put(Max External-Xmin+1)            {Number of externals}
            %while Xmin <= Max External %cycle
               N = Xmap(Xmin)
               C = Xused(Xmin)
               Printch(C)
               %if C = Code Reloc %start        {Code reference via label}
                  Put(Item(N)_Ca)
               %finish %else %start             {Gla reference}
                  Put(N)
               %finish
               Put Text(Xmin)
               Xmin = Xmin+1
            %repeat
         %end
         %routine Dump External References
            %integer P, N
            N = 0
            Put(Xnum)
            P = Spec List
            %while P # 0 %cycle
               %if Xspec(P) = "@DISPLAY" %start
                  Fail("Duplicate display") %if Display Reloc # 0
                  Display Reloc = P
               %finish
               Put Text(P)
               N = N+1
               Fail("Corrupt spec") %if Xmap(P) # N
               P = Xused(P)
               Xnum = Xnum-1
            %repeat
            Fail("Spec lost") %if Xnum # 0
         %end
         %routine Dump object file header
            Put(More)
            Put(Total Ca+Constant Size)
            Put(Own Size)
            Put(0)
            Put(0)
            Put(Events)
            Put String(Section)
            Dump External Definitions
            Dump External References
         %end
         %routine Next Min
            Min = Min-1
         %end

      T == Null
      Bias = 0
      Unreachable = 0
      Dump object file header %if Head Tag = 0
      Head == Item(Head Tag)
      Next Min;  B  == Item(Min)
      Next Min;  Bx == Item(Min)
      Fail("Block phase error") %unless Head_Label == B %and B_Link == Bx
      Ca == Code Base
      Attr = B_Attr
      Ca   = Head_Ca
      Set loc(Select Code)
      Dump Header(B)
      %Cycle
         Readch(Sym)
         ->C(Sym) %if 31 <= Sym <= 54
         Fail("Unknown objective ".ItoS(Sym, 0))

C(31):   {Select <<Area>> <<Ca>>}

         N = Two Bytes
         X = Two Bytes
         %if N = 0<<1+0 %start            {code area - i.e. resume}
            N = Select Code
            Ca == Code Base
         %finish %else %if N = 1<<1+0 %start  {constant area}
            N  = Select Code
            Ca == Constant Base
            Ca = X+Total Ca
         %finish %else %start                 {gla area}
            N  = Select Gla
            Ca == Gla Base
            Ca = X
         %finish
         Set Loc(N)
         %continue

C(34):   {Byte: [B]}

         Readch(N);  Dump1(N);  %continue

C(35):   {Dummy}

         Next Min
         Fail("Dummy phase error") %unless Item(Min)_Type = McUsed
         %continue

C(37):   {Switch}

         Lb <- Two signed Bytes;  Ub <- Two signed Bytes;  X = Two Bytes
         %for N = Lb, 1, Ub %cycle
            X = X+1
            T == Item(X)
            Printch(5);  Dump2(T_Ca)
         %repeat
         %continue

C(46):   {Word: <<W>>}

         Dump2(Two Bytes+Bias);  Bias = 0
         %continue

C(47):   {LNB1: <<W>>}

         N = Two Bytes
         %if Attr&Attr Dynamic = 0 %start
            N = N+1 %if N&7 = 4            {LNB->DS}
         %finish
         Dump2(N)
         %continue

C(48):   {LNB2:  <<W>>}

         N = Two Bytes
         %if Attr&Attr Dynamic = 0 %start
            N = N+1<<6 %if N&7<<6 = 4<<6   {LNB->DS}
            N = N+1    %if N&7    = 4      {LNB->DS} %c
                      %and N&k'70' # 0    {leave R4 dest alone}
         %finish
         Dump2(N)
         %continue

C(54):  {LNB10: <<W>>}
         N = Two Bytes
         %if Attr&Attr Dynamic = 0 %start
            N = N+1<<6 %if N&7<<6 = 4<<6
         %finish
         Dump2(N)
         %continue

C(38):   {Jump: <CC>}

         Readch(Cc)
         Next Min;  T == Item(Min)
Jump:    %if T_Flags&Removed = 0 %start
            %if T_Type = Return %start                  {jump to return}
               Fail("Conditional return") %if Cc # 7
               Dump Return(B)
            %finish %else %start
               Fail("Phase error") %if (Cc # 7 %and T_Type = Uncond) %or %c
                                       (Cc = 7 %and T_Type =   Cond)
               Cc = Inverted(Cc) %if T_Flags&Invert # 0
               N = T_Label_Ca-(Ca+2)             {distance to go}
               %if T_Flags&Long = 0 %start       {short branch required}
                  Fail("Stretch error") %unless -256 <= N <= 254
                  Dump2(Branch(Cc)+(N>>1)&255)
               %finish %else %start
                  %if T_Type = Cond %start      {long conditional}
                     Cc = Inverted(Cc)
                     Dump2(Branch(Cc)+2)          {skip the long jump}
                     N = N-2
                  %finish
                  Dump2(8_000167);  Dump2(N-2)
               %finish
            %finish
         %finish
         Unreachable = 1 %if T_Flags&Unreach # 0
         %continue

C(36):   {Call}

         Next Min;  T == Item(Min)
         %if Call <= T_Type <= CallP2 %start
            Dump2(8_004767)               {JSR_PC,@??}
            Ot == T_Label
            Dump2(T_Label_Ca-(Ca+2))
            %continue
         %finish
         Cc = 7 {unconditional}
         ->Jump

C(39):   {Return}

         Next Min;  T == Item(Min)
         Fail("Phase error") %unless T_Type = Return
         Dump Return(B) %unless T_Flags&Removed # 0
         %continue

C(40):   {Line: <<N>>}

         Printch(Line No)
         This Line = Two Bytes
         Put(This Line)
         %continue

C(42):   {External:  <<N>>}

         N = Two Bytes
         Printch(Pc Reloc) %if N&1 # 0
         N = N>>1
         %continue %if N = 0
         Fail("External out of range") %unless N <= Xmax
         %if N <= 2 %start                  {local relocation}
            Bias = Total Ca %if N = 1
            Printch(N-1+Code Reloc)
         %finish %else %start
            X Reloc(N)
         %finish
         %continue

C(44):   {Block}

         Phase 3(Two Bytes, Level+1)
         Set Loc(Select Code)
         %continue

C(45):   {Label:  <<Tag>>}

         N = Two Bytes
         T == Item(N)
         Unreachable = 0 %if T_Type # OldLab   {can get here again}
         %continue

C(49):   {Branch: <<Tag>> <<OP>>}

         Next Min
         N = Item(Two Bytes)_Ca-(Ca+2)
         Fail("Branch cannot reach label") %unless -256 <= N <= 255
         Dump2(Two Bytes+(N>>1)&255)
         %continue

C(50):   {Sob:    <<Tag>> <<Op>>}

         Next Min
         N = (Ca+2)-Item(Two Bytes)_Ca   {Note reversed}
         Fail("Branch cannot reach label") %unless 0 <= N <= 127
         Dump2(Two Bytes+(N>>1))
         %continue

C(51):   {Modlab:  <<Tag>> <<Mod>>}

         Next Min
         T == Item(Two Bytes)
         Dump2(Two Bytes+T_Ca-(Ca+2))
      %repeat

C(33):{End}
      N = Two Bytes
      %if N # 0 %start               {event mask}
         Printch(Event Block)
         Put(N)                      {events trapped}
         Put(Item(Two Bytes)_Ca)     {event block address}
         Put(Item(Two Bytes)_Ca)     {start of scope}
         Put(Ca)                     {end of scope}
         Event Count = Event Count-8
      %finish
      Min = Min-1

   %end

   Section = ""
   %cycle
      Z == Null
      Parm List == Null

      Xmin      = Max External+1
      Xmax      = 2
      Xnum      = 0
       Xmap(SpMove)  = 0
      Xspec(SpMove)  = "P#SPMOVE"
      Xused(SpMove)  = 0
      Spec List = 0
      Spec End  == Spec List
      This Line = 0
      Max       = 0
      Min       = Max Item+1
      Order == Null
      Select Input(Directives);  Select Output(0);          Phase 1(0)
      Spec End = 0
                                                            Phase 2
           Own Size = (Two Bytes+1)&(\1)
      Constant Size = (Two Bytes+1)&(\1)
             Events = Two Bytes
        Event Count = Events
      Readch(More)
      More = More-NL    {0=no more, 5=more}
      Get Text(New Section) %if More # 0

      Min = Max Item+1
      Select Input(Objectives);  Select Output(Object);     Phase 3(0, -1)
      Printch(Eof)
      Select Output(0)
      Fail("Corrupt events") %if Event Count # 0
      Printstring(Section); Spaces(20-Length(Section))
      Section = New Section;  New Section = ""
      Printstring("Code");         Write(Total Ca, 1)
      %if Own Size # 0 %start
         Printstring(" + Gla");        Write(Own Size, 1)
      %finish
      %if Constant Size # 0 %start
         Printstring(" + Constants");  Write(Constant Size, 1)
      %finish
      %if Events # 0 %start
         Printstring(" + Events");  Write(Events, 1)
      %finish
      Printstring(" =");           Write(Total Ca+Own Size+Constant Size+Events, 1)
      Printstring(" bytes")
      Newline
   %repeat %until More = 0

%endofprogram