!***********************************
!* WARNING                         *
!* An extra null string has been   *
!* added to the PRIM ID array to   *
!* get rid of an obscure bug       *
!* which shows up in the following *
!* trivial Pascal program when     *
!* compiled with all checks:       *
!*                                 *
!* program f;                      *
!* var a:array[1..100] of integer  *
!* begin                           *
!* end.                            *
!***********************************

                {###################################}
                {#       Copyright (C) 1987        #}
                {#           3L Limited            #}
                {#            Scotland             #}
                {#                                 #}
                {#       All rights reserved       #}
                {###################################}

                       {Pass3 for ARM compiler}

! Bugs:
!   1. Record diagnostics are currently global to the whole file;
!      they need to be made block-local so that they can be removed
!      when the containing block is unused.

%externalstring(3) P3 Version = "002"

%constinteger AOF Version = 150

!
! Revision history
! 002 22-Jun-88 PSR Converted to run native on an A310
!                   Changed strings for diags to 127 from 3
! 001  4-FEB-88 PSR Started inserted support for ARM Debugger
!                 - Removed Position-independent bit from Code area definition
!     21-aug-86 AET corrected static initialisation of char pointer variables
!                   in C.
!
! 0.3 22-jul-86 PSR corrected absorb jumps in the case: if a & b then c else d
!     25-jun-86 AET changed pass3 to create output file in new ARM format
!                   using a similar method as in the P.E. pass3.
!
! 0.2 26-Mar-86 PSR changed module info to be relative to start of info
!                   rather than each element self-relative.
!                 - made line tables default code increment to 4 (was 1)
!                 - changed processing of if then else to include
!                   calls and return + increased the range slightly
!     24-Mar-86 PSR Released to Acorn
! 0.1 15-FEB-86 PSR cloned from M68K Version 2.6

%from IMP %include HEAP
%externalintegerfnspec Encoded Value
%externalroutinespec   Dump Encoded(%integer N)
%externalroutinespec   Open Object File(%integer Size)

%externalstring(7)%spec   P1 Version, P2 Version
%externalstring(31)%spec  Product Code,
                          Version, Release, Revision
%externalintegerspec      Debug Options %alias "3L_DEBUG_OPTIONS"

%constinteger W = 4     {Bytes per word}

%owninteger             Current Line = 0

%from IMP %include Interfac, Option3l, Stream3l, Spec3l, Attr, Comm23

%externalroutine PASS 3(%record(CommFm)%name Interface)
   %integer Options = Interface_Options,                                   {001}
            DEBUG   = Options&LL Debug                                     {001}

   %recordformatspec Blockfm

   %recordformat Itemfm(%record(Itemfm)%name  Link,
                        %integer              Ca,
                        (%byte Cond, Type, %short Flags  %or
                         %byte Prim                      %or
                         %byte X1, X2,     %short Ahead  %or
                         %byte Args),
                        (%record(Itemfm)%name  Label     %or
                         %record(Blockfm)%name Head      %or
                         %short                Lb, Ub    %or
                         %integer              Value))

   {Item Types}

   %constinteger  Label Type = 0,
                 Return Type = 1,
             Array Disp Type = 3,
               External Type = 5,
                   Addr Type = 6,
                  Caddr Type = 8,
                  Cload Type = 9,
                  Rload Type = 10,
                  Sload Type = 11,
                 xThunk Type = 12

   %constinteger Type Bias = 13

   %constinteger Branch Type = Type Bias+0,{these types have valid LABEL fields}
                   Call Type = Type Bias+1,
                   Prim Type = Type Bias+2,
                   Disp Type = Type Bias+4,
                   Jump Type = Type Bias+6,
                  Thunk Type = Type Bias+7,
                  Final Type = Type Bias+7

   {Block flags}

   %constinteger   Used = 16_ 0 01,
               No Entry = 16_ 1 00,
              Ext  Flag = 16_ 4 00,
             Displ Flag = 16_ 8 00

   {Item flags}

   %constinteger Conditional = 1<<0,
                 Long        = 1<<1,
                 VeryLong    = 1<<2,
                 Minimum     = 1<<3,

                 Deleted     = 1<<7,

                 Marked      = 1<<8,
                 Duplicated  = 1<<9,
                 Forward     = 1<<10,
                 Label Used  = 1<<11,
                 Absorbed    = 1<<12,
                 Referenced  = 1<<13

   %recordformat Xfm(%integer    Disp,  {entry disp from start of global area}
                     %integer    Flags, {string index<<8 ! flags}
                     %integer    Value, {entry value for definitions}
                     %string(31) Text)

   %const %integer Ext Defn      = 1<<0,
                   Ext Code      = 1<<1,
                   Ext Prim      = 1<<2,
                   Ext Allocated = 1<<5,
                   Ext Dumped    = 1<<6

   %recordformat Usefm(%record(Usefm)%name Link, %record(Xfm)%name X)
   %constrecord(Usefm)%name UsefmType == 0
   %ownrecord(Usefm)%name Total Uses == 0

   %owninteger Main Program = 0,
               String Size = 4,         {skip initial string-table size}
               User String Base = 0,
               SymTsize,
               ActiveSize,
               Total Size,
               Header Size

   %ownstring(31) Main Entry Id     {IMP___ENTRY_POINT or PASCAL___ENTRY_POINT}

   %recordformat Blockfm( -
        %record(Itemfm)%name  Label,
                              Items,
        %byte                 Pregs,
                              Return,
        %integer              Flags,
                              Attr,
                              Display,
                              Event Mask,
                              Event Label,
                              Event Body,
                              Ca,
                              Body,
                              Code Size,
                              Code Base,
                              Line Size,
                              Line Base,
                              Diag Size,
                              Diag Base,
                              Frame,
                              Pframe,
        %record(Xfm)%name     X,
        %record(Usefm)%name   Uses,
        %record(Blockfm)%name Link)

%include "inc.DEBUG"                                               {001}
%include "inc.DEBUGFM"

   %constbytearray Inverse(0:23) = 7,
                                   6,  5,  4,  3,  2,  1,  0,  9,  8,  0,
                                  16, 15, 14, 13, 12, 11, 10, 19, 18,
                                  21, 20, 23, 22

   %owninteger Ip = 0,                   {item poiter}
               Bp = 0                    {block pointer}

   %integer Other Basis  = 0,    {these are global to all blocks}
            Record Basis = 0,
            Global Basis = 0,
            Bugs Basis   = 0

   %constinteger CSeg = 0,    DSeg = 1,  Bseg = 2                 {001}
   %integer      Code Size,   Data Size, Bugs Size = 0            {001}
   %integer      Files Size = 0, NN

   {The following are displacements into the string table}
   %constinteger CodeArea = 16_04,
                 DataArea = 16_0E,
                 DbugArea = 16_18,                                {001}
                 FreeArea = 16_22

   %constinteger   CSym = 0, DSym = 1, BSym = 2, ESym = 3

   {Bases for constant and global areas, note that code base is local to dump}
   {block as the code size isn't known to Pass2 so code is divided into a}
   {number of local areas, 1 per block}

   %owninteger Min SB    = 0,
               Max SB    = 0

!                    Sb
!                    |
!     Min SB - - - - * + + + + Max SB
!         |          |             |
!         v          v             v
!        *----------*-*-------------*
!        |          | |             |
!        *----------*-*-------------*

   %owninteger Bias             = 0,
               Reloc            = 0,
               Xreloc           = 0,
               Record Size      = 0,
               Number of Blocks = 0,
               Start Point      = -1,
               Ep

   %recordformat Linefm(%integer Ca, Last Ca, Line, Last Line, Pending)

   %recordformat Areafm(%integer Code, Constant, Block, Line,
                                 Diag, Record, Global, Global Array)

   %ownintegername Ca == 0                {is pointed into Area Base}
   %owninteger     Previous Ca = 0

   %record(Itemfm) %array    Items(0:Interface_Total Items)
   %record(Blockfm)%array   Blocks(0:Interface_Total Blocks)
   %short          %array   Formpt(1:Interface_Total Formats)
   %record(Xfm)    %array External(0:Interface_Total Externals)

   NN = Interface_Total Formats
   NN = 1 %if Debug = 0
   %record(DFormatPFm)%array DebugFm(1:NN)

   %record(Blockfm)%name Block List == Nil,
                         Main Head  == Nil,
                         Entry Head == Nil
   %record(Xfm)%name Entry X == NIL

   %owninteger Max External = 0

   %owninteger Xentry      =  0,
               Xentry Base =  0, Extra Base = 0

   {Prim data}

   %constinteger Last Prim = 57     {*****see top comment about null string ***}

   %constinteger Sw Jump    =  4,   {**** known in PRIM file ****}
                 Sw Error   = 24,   {disp of error in SWJUMP routine}
                 Enter Prim = 55    {prim number of ENTER}

   %conststring(9)%array Prim Id(1:Last Prim) =
   { 1}   "SIGNAL",   "CSCOMP",    "SRES",   "SWJUMP",    "INTEXP",
   { 6}  "REALEXP",  "GENMOVE",   "SCONC",    "SCOMP",      "SJAM",
   {11}    "SETIN",  "RESFLOP", "TESTNIL","MAKELOCAL",      "AREF",
   {16} "DYNRANGE", "DYNAMICN",   "FRAG1","RTMONITOR",    "SETBIT",
   {21}  "CAPTEST",  "ASSTEST",  "LTRACE",    "FRAG2",  "CLEARBIT",
   {26}  "TESTNEW",  "TESTNIL", "SETBITS",   "SETADD",    "SETSUB",
   {31} "SETINTER",    "SETGE",   "RANGE",  "TESTMOD", "CLEARBITS",
   {36}  "TESTVAR",  "PRIMMUL", "PRIMDIV", "TESTREAL",  "PRIMCOMP",
   {41} "REALINTPT", "MODULUS","DYNAMIC1", "DYNAMIC2",      "PSYM",
   {46} "SETRANGE",   "READCH",  "NEXTCH", "PRIMUDIV",   "SETZERO",
   {51} "SETEQUAL",  "REALINT", "REALRND",    "CALLP",    "ENTERP",
   {56}   "DALLOC",  ""

   %ownintegerarray Prim  Map(1:Last Prim) = 0(*)
   %ownbytearray    Prim Used(1:Last Prim) = 0(*)

   %ownstring(63) Block Id = ""

   %string(127) Included File = "", Swork

   %ownrecord (Areafm) Area size = 0             {area sizes}
   %ownrecord (Areafm) Area base = 0             {area base addresses}

   %ownrecord(Procedurefm) Debug Base                             {001}
   %owninteger Total Debug List = 0                               {001}
   %ownrecord(DvarFm)%name DGlobals == 0
   %ownrecord(DformatFm)%name Fglobals == 0

   %ownrecord(Filefm)%name DebugF == 0, DebugFiles == 0

   %routine CSR(%string(255) Why)
      %routine Err(%integer Stream)
         Select Output(Stream)
         Printstring("Pass 3 fails -- ".Why)
         Printstring(" at line");  Write(Current Line, 1)
         %if Included File # "" %start
            Printstring(" in include file ")
            Printstring(Included File)
         %finish
         Newline
      %end
      Err(Listing)                        {listing}
      Err(Report)                         {terminal}
      %monitor
      %stop
   %end

   %routine A Error(%integer Ca, Lim)
      CSR("Address error CA:".ItoS(Ca, 0)." Lim:".ItoS(Lim, 0))
   %end

   %routine Show Code(%integer N)
      Select Output(Report)
      Printstring("Code:")
      Write(N, 0)
      Newline
      Select Output(Object Out)
   %end

   %routine Warn(%string(255) What)
      Select Output(Report)
      Printstring("Warning -- ".What)
      Printstring(" at line ");  Write(Current Line, 0)
      Newline
      Select Output(Object Out)
   %end

   %integerfn Padded(%string(*)%name S)
      %result = (Length(S)+1+3)&(\3)
   %end

   %routine Set Debug Line(%integer Ca, Line)
      %record(DlineFm)%name L, X
      %return %if Debug = 0          {build a circular line-number list}
      L == DebugF_Frag_Lines      {pointer to LAST entry}
      %if L == NIL %start         {first line}
         X == NEW(DlineFmType)
         X_Line = Line
         X_Ca = Ca
         X_Link == X
         DebugF_Frag_Lines == X
      %else %if L_Ca = Ca         {no code generated since last line}
         L_Line = Line            {just overwrite the line number}
      %else                       {add a new line item}
         X == NEW(DlineFmType)
         X_Line = Line
         X_Ca = Ca
         X_Link == L_Link         {forward pointer}
         L_Link == X
         DebugF_Frag_Lines == X
      %finish
   %end

   %record(Filefm)%map New Debug File
      %record(Filefm)%name F
      F == NEW(FilefmType)
      F_Frag  == NIL
      F_Flink == NIL
      F_Link  == DebugFiles
      DebugFiles == F
      %result == F
   %end

   %routine Debug New Fragment(%integer Ca, Line)
      %record(FragmentFm)%name Fr
      %return %if Debug = 0
      Fr == DebugF_Frag
      %if Fr == NIL %or Fr_From <= Fr_To %start   {get a new one or overwrite}
         Fr == NEW(FragmentFmType)
         Fr_Link == DebugF_Frag
         DebugF_Frag == Fr
      %finish
      Fr_Code = Ca;    Fr_CodeSize = 0
      Fr_From = Line;  Fr_To = 0
      Fr_Lines == NIL
      Set Debug Line(Ca, Line)
   %end

   %routine Debug Terminate Fragment(%integer Ca, Line)
      %record(FragmentFm)%name Fr
      %record(Dlinefm)%name L
      %return %if Debug = 0
      %return %if DebugF == NIL
      Fr == DebugF_Frag
      Fr_To       = Line
      Fr_CodeSize = Ca-Fr_Code
      L == Fr_Lines
      %if L ## NIL %start          {break the loop}
         Fr_Lines == L_Link        {point to the first one}
         L_Link == NIL             {and terminate the list}
      %finish
   %end

   %routine Debug Include(%string(255) File, %integer Ca, Line)
      %record(Filefm)%name F
      %return %if Debug = 0
      %if File # "" %start             {going into a new include file}
         Debug Terminate Fragment(Ca, Current Line-1)
         F == New Debug File
         F_File == Heap String(File)
         F_Flink == DebugF
         DebugF == F
      %else                            {leaving an include file}
         Debug Terminate Fragment(Ca, Current Line)
         DebugF == DebugF_Flink
      %finish
      Debug New Fragment(Ca, Line)
   %end

{object format control items}

   %recordformat Symbolfm(%integer Name, Value, %byte Area, Attributes,
                          %record(SYmbolfm)%name Link)
   %constrecord(Symbolfm)%name SymbolfmType == 0
   %integer Symbol Entry No = -1
   %record(Symbolfm) Symbol Base
   %record(Symbolfm)%name Symbol List == Symbol Base

   %integerfn Symbol Entry(%integer Name, Attributes, Value, Area)
      %record(Symbolfm)%name S == NEW(SymbolfmType)
      S_Name       = Name
      S_Value      = Value
      S_Area       = Area
      S_Attributes = Attributes
      Symbol List_Link == S
      Symbol List      == S
      Symbol Entry No = Symbol Entry No+1
      %result = Symbol Entry No
   %end

   %recordformat Relocfm(%integer Vaddr, Code, %record(Relocfm)%name Link)
   %constrecord(Relocfm)%name Relocfm Type == 0

   %constinteger SymbolReloc = 2_1010,
                     PcReloc = 2_0110

   %recordformat SegmentRfm(%record(Relocfm)%name R, %integer Entries, Base)
   %record(SegmentRfm)%array Segment Reloc(Cseg:Bseg)

   %owninteger Current Address = 0,
               Current Limit   = 0

   %ownintegerarray Segment  Base(Cseg:Bseg) = 0, 0, 0
   %ownintegerarray Segment Limit(Cseg:Bseg) = 0, 0, 0

   %routine Dump String(%string(255) S)
      %integer N
      String(Current Address) = S
      N = Length(S)+1
      Current Address = Current Address + N
      %if Current Address > Current Limit %start
         A Error(Current Address, Current Limit)
      %finish
      Ca = Ca+N
   %end

   %routine Select(%integer Segment, Displacement)
      {Segment is either CSeg or DSeg}
      Current Address = Segment Base(Segment) + Displacement
      Current Limit   = Segment Limit(Segment)
      %if Displacement < 0 %or Current Address > Current Limit %start
         A Error(Current Address, Current Limit)
      %finish
      {permit selecting a NULL area}
   %end

   %routine Select Global Area(%integer Bias)
      Ca == Global Basis
      Ca = Area Base_Global + Bias
      Select(DSeg, Ca - Min SB)
   %end

   %routine Get String(%string(*)%name S, %integer Limit)
      %integer Sym, L
      Readsymbol(L)
      S = ""
      %while L > 0 %cycle
         L = L-1
         Readsymbol(Sym);  S = S.Tostring(Sym) %unless Length(S) = Limit
      %repeat
   %end

   %routine Put String(%string(255) S)
      %integer P
      Printsymbol(Length(S))
      Printsymbol(Charno(S,P)) %for P = 1, 1, Length(S)
   %end

   %routine Skip Bytes(%integer N)
      %while N > 0 %cycle
         N = N-1;  Skipsymbol
      %repeat
   %end

   %integerfn Displacement Size(%integer N)
      %result = 1 %if 16_FFFF FFC0 <= N <= 16_0000 003F
      %result = 2 %if 16_FFFF E000 <= N <= 16_0000 1FFF
      %result = 4
   %end

   %routine Input Block(%integer Block Label, Level)
      %switch D(1: Max Dir)                                {002}
      %record(Blockfm)%name Head
      %record(Itemfm) Base
      %record(Itemfm)%name Item, Terminal == Base, Basep
      %integer Code, N, Q, Label, Lb, Ub, Needs
      %integer Diag Size, Record Diags = 0
      %integer Diag Inc
      %integer Line Size, Local Code Base, Dummy Code Base = 0
             {These are used to guestimate the size of the line-number table}
             {Last Ca is moved back whenever a stretchable object is defined}
             {This should overestimate the size of the line area, which is safe}
             {The line table is of the form: }
             {  [nnnnnn00]               6-bit code increment}
             {  [nnnnnn10]               6-bit line increment}
             {  [nnnnnnnn] [nnnnnn01]   14-bit code increment}
             {  [nnnnnnnn] [nnnnnn11]   14-bit line increment}
      %record(Xfm)%name X
      %record(Linefm) Line Info = 0
      %integer D1, D2

      %routine Allocate Line Diag
         %integer N, C
         Line Info_Line = Current Line
         Line Info_Ca   = Ca
         N = Line Info_Line - Line Info_Last Line
         C = Line Info_Ca   - Line Info_Last Ca-1
         %if N > 0 %and C > 0 %and Options&LL Lines # 0 %start
            Line Info_Last Line = Line Info_Line
            Line Info_Last Ca   = Line Info_Ca
            Line Size = Line Size+1
            Line Size = Line Size+1 %if C >= 64      {too big, needs a reset}
            %if N # 1 %start                         {needs an explicit increment}
               N = N-2
               Line Size = Line Size+1
               Line Size = Line Size+1 %if N >= 64   {needs a big increment}
            %finish
         %finish
      %end

      %routine Alloc Diag
         %integer L, F, Key, N, Type, Xtype
         %string(127) S                       {002}
         Get String(S, 127);  L = Length(S)
         Key = Encoded Value;  Type = Key>>2&15
         Xtype = Encoded Value
         N = Encoded Value
         %if Key = 0 %start                 {enumerated name}
            L = L+1
         %else
            L = L+1 {string size} +1 {key} +Displacement Size(N)
            %if Key&64 # 0 %start          {format follows}
               F = Encoded Value
               L = L+2
            %finish
            L = L+1 %if Xtype # 0
         %finish
         %if Record Diags = 0 %then    Diag Inc =   Diag Inc+L  -
                              %else Record Size = Record Size+L
      %end

      %record(Itemfm)%map New Item(%integer Type)
         %record(Itemfm)%name P
         Ip = Ip+1;  P == Items(Ip)
         P_Type  = Type
         P_Ca    = Ca
         P_Flags = 0
         Terminal_Link == P
         Terminal      == P
         Line Info_Last Ca = Line Info_Last Ca-3        {assume the worst}
         %result == P
      %end

      %routine Set Prim(%integer N)
         %record(Itemfm)%name Item
         Item == New Item(Prim Type)
         Ca = Ca+4
         Item_Flags = Minimum
         Item_Prim = N;  Prim Used(N) = 1
      %end

      %routine Add Use(%integer Xn)
         %record(Usefm)%name U
         %record(Xfm)%name X
         X == External(Xn)
         U == Head_Uses
         %while U ## Nil %cycle
            %return %if U_X == X
            U == U_Link
         %repeat
         U == NEW(UsefmType)
         U_X == X
         U_Link == Head_Uses;  Head_Uses == U
      %end

      Line Info_Line = Current Line;  Line Info_Last Line = Current Line
      Line Info_Ca   = 0;             Line Info_Last Ca   = 0

      Ca == Local Code Base                       {revert to code area}
      Ca  = 0                                     {start at the beginning}
      Bp = Bp+1;  Head == Blocks(Bp);  Head = 0
      Head_Label == Items(Block Label);  Head_Label = 0
      Head_Label_Head == Head
      Head_Link == Block List %and Block List == Head %unless Level < 0 {remove}
      Line Size = 0                                                  {unwanted}
      Diag Size = 4 + Length(Block Id)+1                             {blocks}
      Diag Inc = 0
      Needs = 0
      %cycle
         Readsymbol(Code)
         %unless 1 <= Code <= Max Dir %start                      {002}
D(*):       CSR("Corrupt p1 directive".ItoS(Code, 1))
         %finish
         Show Code(Code) %if Options&LL Mon # 0
         ->D(Code)

{******** Debugger Support ********}
D(Dir DEBUG Start Proc):   D1 = Encoded Value     {Type}          {001}
                           D2 = Encoded Value     {Sourcepos}     {001}
                           %continue                              {001}
                                                                  {001}
D(Dir DEBUG End Proc):     D2 = Encoded Value     {Sourcepos}     {001}
                           %continue                              {001}
{**********************************}

D(Dir Start Block): N = Encoded Value+Reloc
                    Get String(Block Id, 127)                     {002}
                    Input Block(N, Level+1)
                    Ca == Local Code Base
                    %continue

D(Dir Diag):        Alloc Diag;  %continue

D(Dir DEBUG Var):   %begin
                       %integer N
                       %string(255) S
                       Get String(S, 255)
                       N = Encoded Value {Primary type}
                       N = Encoded Value {Indirect bit}
                       N = Encoded Value {Base: 1=Local, 2=Static}
                       N = Encoded Value {BaseType}
                       N = Encoded Value {PointerType}
                       N = Encoded Value {Displacement}
                       N = Encoded Value {Format}
                       N = Encoded Value {Size}
                    %end
                    %continue

D(Dir DEBUG Array): %begin
                       %integer N
                       %string(255) S
                       Get String(S, 255)
                       N = Encoded Value {Lower bound}
                       N = Encoded Value {Upper Bound}
                       N = Encoded Value {Total Size}
                       N = Encoded Value {Type}
                       N = Encoded Value {Format}
                    %end
                    %continue

D(Dir Line):        Current Line = Encoded Value
                    Allocate Line Diag;  %continue

D(Dir Include):     Get String(Included File, 255);  %continue

D(Dir Record On):   Record Diags  = Encoded Value
                    Formpt(Record Diags) = Record Size
                    %continue

D(Dir Record Off):  Record Diags = 0
                    Record Size = Record Size + 1 ;     %continue

D(Dir Slabel):
D(Dir Label):       Label = Encoded Value+Reloc
                    Item == Items(Label)
                    Item_Flags = 0
                    %if Code = Dir Slabel %and Item_Ca >= 0 %start
                       Item_Flags = Duplicated
                       Basep == Base            {already defined - S(*): }
                       %cycle                   {search for & remove old copy}
                          CSR("corrupt switch") %if Basep == Nil
                          %exit %if Basep_Link == Item
                          Basep == Basep_Link
                       %repeat
                       Basep_Link == Item_Link
                       Terminal == Basep %if Terminal == Item {beware last one}
                    %finish
                    Item_Ca = Ca
                    Item_Type = Label Type
                    Item_Head == Head
                    Terminal_Link == Item;  Terminal == Item
                    %continue

D(Dir Mark User):   Item_Flags  = Item_Flags!Marked;  %continue      {show it's user-defined}

D(Dir Const Addr):  Item == New Item(Caddr Type)
                    Item_Cond  = Encoded Value       {register}
                    Item_Value = Encoded Value
                    Item_Flags = 0
                    Ca = Ca+4
                    %continue

D(Dir Const Load):  Item == New Item(Cload Type)
                    Item_Cond  = Encoded Value       {register}
                    Item_Value = Encoded Value
                    Item_Flags = 0
                    Ca = Ca+4
                    %continue

D(Dir Real Load):   Item == New Item(Rload Type)
                    Item_Cond  = Encoded Value       {register}
                    Item_Value = Encoded Value
                    N          = Encoded Value       {0=short, 1=long}
                    Item_Flags = 0
                    Ca = Ca+4
                    %continue

D(Dir Spec Load):   Item == New Item(Sload Type)
                    Item_Cond  = Encoded Value        {register}
                    N          = Encoded Value+Xreloc {external index}
                    Add Use(N)
                    Item_Value = N
                    Needs = Needs ! Attr Needs Gp
                    Item_Flags = 0
                    Ca = Ca+4
                    %continue

D(Dir Branch):      Label = Encoded Value+Reloc
                    Item == New Item(Branch Type)
                    Ca = Ca+4
                    Item_Cond = Encoded Value
                    Item_Flags = Item_Flags ! Conditional %if Item_Cond #  7 -
                                                         %and Item_Cond # 17
                    Item_Label == Items(Label)
                    %continue

D(Dir McLabel):     Label = Encoded Value+Reloc {label}
                    N = Encoded Value           {instruction}
                    Ca = Ca+4
                    %continue

D(Dir Modify):      N = Encoded Value      {address}
                    N = Encoded Value      {auto increment}
                    %continue

D(Dir Header):      N = Encoded Value      {area}
                    N = Encoded Value      {zero'th}
                    N = Encoded Value      {dope vector}
                    Ca = Ca+8
                    %continue

D(Dir Thunk):       Label = Encoded Value+Reloc   {procedure to call}
                    N     = Encoded Value         {Static slot}
                    Item       == New Item(Thunk Type)
                    Item_Label == Items(Label)
                    %continue

D(Dir xThunk):      N = Encoded Value+Xreloc      {external procedure to call}
                    Q = Encoded Value             {Static slot}
                    Add Use(N)
                    %continue

D(Dir Call):        Label = Encoded Value+Reloc
                    Item == New Item(Call Type)
                    Ca = Ca+4
                    Item_Flags = Minimum
                    Item_Label == Items(Label)
                    %continue

D(Dir Ext):         Max External = Max External+1
                    X == External(Max External)
                    Get String(X_Text, 31)
                    X_Flags = Encoded Value
                    X_Disp  = Encoded Value
                    X_Value = -1
                    Main Program = 1 %if X_Text = "3L___main_program" -
                                    %and X_Flags&Ext Code # 0    -
                                    %and X_Flags&Ext Defn # 0
                    Add Use(Max External) %if X_Flags&Ext Defn # 0 -
                                         %and X_Flags&Ext Prim = 0
                    %continue

D(Dir Xref):        N = Encoded Value+Xreloc         {external index}
                    Add Use(N)
                    Q = Encoded Value
                    Ca = Ca+4
                    %continue

D(Dir xCall):       N = Encoded Value+Xreloc
                    Add Use(N)
                    Item == New Item(External Type)
                    Ca = Ca+4
                    Item_Flags = Minimum
                    Item_Value = N
                    Needs = Needs ! Attr Needs Gp
                    %continue

D(Dir Assigned):    Set Prim(22);  %continue

D(Dir Prim):        N = Encoded Value;  Set Prim(N);  %continue

D(Dir Return):      Item == New Item(Return Type);  Ca = Ca+4
                    Item_Flags = Minimum
                    Item_Value = Encoded Value
                    %continue

D(Dir Area):        Q               = Encoded Value    {area}
                    Dummy Code Base = Encoded Value    {offset}
                    Ca == Dummy Code Base
                    Ca == Local Code Base %if Q = 0    {offset is ignored}
                    %continue

D(Dir Swdef):       Lb = Encoded Value+Reloc
                    Ub = Encoded Value+Reloc
                    Items(N)_Ca = -1 %for N = Lb, 1, Ub
                    %continue

D(Dir Sw Ref):      N = Encoded Value;  Ca = Ca+4;  %continue

D(Dir Init):        N = Encoded Value
                    N = Encoded Value
                    Ca = Ca+4
                    %continue

D(Dir Dump):        N = Encoded Value;  Skip Bytes(N);  Ca = Ca+N

      %repeat

D(Dir End Block):   Head_Frame           = Encoded Value&(\3)+20  {negative}
                    Head_Code Size       = Encoded Value
                    Head_Pframe          = Encoded Value-4
                    Head_Pregs           = Encoded Value
                    Head_Display         = Encoded Value
                    N                    = Encoded Value
                    N                    = Encoded Value
                    Head_Attr            = Encoded Value ! Needs
                    N                    = Encoded Value
                    Head_Event Mask      = Encoded Value
                    Head_Event Label     = Encoded Value+Reloc
                    Head_Event Body      = Encoded Value+Reloc
                    Terminal_Link  == Nil
                    Head_Items == Base_Link
                    %if Head_Attr&Attr Prim # 0 %start  {strip external bits}
                       Head_Attr = Head_Attr & (Attr Needs Gp!Attr Prim)
                    %finish
                    Diag Inc = 0 %if Options&LL Vars = 0 -
                                 %or Head_Attr&Attr Prim # 0
                    Head_Line Size = (Line Size+5+3)&(\3)          {a bit spare}
                    Diag Size = 0 %if Options&LL Vars = 0
                    Head_Diag Size = (Diag Size+Diag Inc+1+3)&(\3) {+ term}
                    Head_Line Size = 0 %if Options&LL Lines = 0
                    Head_Diag Size = 0 %if Options&LL Trace = 0
   %end

   %routine Define Prim Map
      %integer J, Failed = 0
      %record(Xfm)%name X

      %routine Define Prim(%string(31) Text, %integer Value)
         %integer M = 0
         %while M # Last Prim %cycle
            M = M+1
            %if Prim Id(M) = Text %start
               CSR("duplicate Prim routine ".X_Text) %if Prim Map(M) # 0
               Prim Map(M) = Value
               %return
            %finish
         %repeat
         {unknown - just ignore it}
      %end

      %for J = Interface_External Count+1, 1, Interface_Total Externals %cycle
         X == External(J)
         Define Prim(X_Text, X_Disp+Reloc) %if X_Flags&2_100 # 0  {a Prim def}
      %repeat
      %for J = 1, 1, Last Prim %cycle
         %if Prim Used(J) # 0 %and Prim Map(J) = 0 %start
            Warn("missing Prim routine ".Prim Id(J))
            Failed = 1
         %finish
      %repeat
      CSR("Missing primitive procedures") %if Failed # 0
   %end

   %integerfn Place String(%string(255) S)
      %integer P = String Size
      String Size = String Size + Length(S)+1
      %result = P
   %end

   %routine Allocate External(%record(Xfm)%name X)
      %record(Blockfm)%name H
      %return %if X_Flags & Ext Prim # 0       {ignore prim routines}
      X_Flags = X_Flags ! Ext Allocated ! Place String(X_Text)<<8
      %if X_Flags&Ext Defn = 0 %start          {reference}
         %if X_Flags&Ext Code = 0 %start       {only allocate data references}
            %if Max SB <= 4094 %start
               X_Disp = Max SB;  Max SB = Max SB+4
            %else
               Min SB = Min SB-4;  X_Disp = Min SB
               CSR("Too many external references") %if Min SB < -4096
            %finish
         %finish
      %else %if X_Flags&Ext Code # 0           {code definition}
         H == Items(X_Disp)_Head
         %if X_Text = "3L___main_program" %start
            Interface_Specials = Interface_Specials ! Special Main
            Main Head == H
            Start Point = X_Disp
            CSR("main program found") %if Main Program = 0
         %else %if X_Text = "3L_imp___entry_point"    -
               %or X_Text = "3L_pascal___entry_point"
            Entry Head == H
            Entry X == X
         %finish
         H_X == X                              {back link from block header}
      %finish
   %end

   %routine Mark Unused Blocks
      %record(Blockfm)%name This Block
      %record(Usefm)%name U, UU
      %integer N

      %routine Mark blocks used by(%record(Blockfm)%name This Block,
                                   %integername Attr)
         %integer A
         %record(Blockfm)%name B
         %record(Itemfm)%name Item == This Block_Items
         This Block_Flags = This Block_Flags!Used
         %if This Block_Attr&Attr Both # 0 %start     {uses non-locals}
            This Block_Flags = This Block_Flags ! Displ Flag
         %finish
         %if This Block_Attr&Attr Prim # 0 %start     {is a Primitive block}
            This Block_Line Size = 0
            This Block_Frame     = 0
            This Block_Flags     = This Block_Flags!No Entry
         %finish
         %while Item ## Nil %cycle
            %if Item_Type >= Branch Type %start
               %if Item_Type = Prim Type %and Item_Flags&Minimum # 0 %start
                  Item_Flags = Item_Flags-Minimum
                  Item_Label == Items(Prim Map(Item_Prim))
               %finish
               B == Item_Label_Head
               B_Attr = B_Attr ! Attr Xdef %if Item_Type = Thunk Type
               A = B_Attr&Attr Needs Gp
               Attr = Attr ! A
               This Block_Attr = This Block_Attr ! A
               Mark blocks used by(B, Attr) %if B_Flags&(Ext Flag!Used) = 0
            %finish
            Item == Item_Link
         %repeat
      %end

     {mark the initial entries as unused}


      This Block == Block List
      %while This Block ## Nil %cycle
         %if This Block_Attr&Attr Xdef # 0 %start     {trace from external root}
            %if This Block_Flags&Used = 0 %start
               This Block_Flags = This Block_Flags ! Ext Flag
               Mark blocks used by(This Block, This Block_Attr)
            %finish
         %finish
         This Block == This Block_Link
      %repeat

      {finally build the list of used blocks}

      Number of Blocks = 0

      U == Blocks(0)_Uses
      %while U ## NIL %cycle
         UU == U_Link
         %if U_X_Flags&Ext Defn # 0 %start
            U_Link == Total Uses;  Total Uses == U
         %finish
         U == UU
      %repeat

      %record (blockfm) %name B

      This Block == Block List
      Block List == Nil
      %while This Block ## Nil %cycle
         B == This Block_Link
         %if This Block_Flags&Used # 0 %start  {the block has been used}
            This Block_Link == Block List
            Block List == This Block
            Area Size_Line = Area Size_Line + This Block_Line Size {sum sizes for use}
            Area Size_Diag = Area Size_Diag + This Block_Diag Size {in allocating segm.}
            U == This Block_Uses
            %if U ## NIL %start
               U == U_Link %while U_Link ## NIL
               U_Link == Total Uses
               Total Uses == This Block_Uses
            %finish
            Number of Blocks = Number of Blocks+1
         %else                                 {not been used}
            U == This Block_Uses               {keep data definitions}
            %while U ## NIL %cycle
               UU == U
               U == U_Link
               %if UU_X_Flags&Ext Defn # 0 %and                          -
                   UU_X_Flags&Ext Code = 0 %start
                  UU_Link == Total Uses;  Total Uses == UU
               %finish
            %repeat
         %finish
         This Block == B
         %repeat

      {now allocate the externals, done here to ensure the correct order}
      N = Place String("$CODEAREA")
      N = Place String("$DATAAREA")
      N = Place String("$DBUGAREA") %if Debug # 0
      N = Place String(Main Entry Id) %if Main Program # 0
      User String Base = String Size

      U == Total Uses
      %while U ## NIL %cycle
         %if U_X_Flags&Ext Allocated = 0 %start
            Allocate External(U_X)
         %else
            U_X == NIL
         %finish
         U == U_Link
      %repeat
   %end

   %predicate Compatible(%integer CC1, CC2)
      %integer M1, M2
      %constinteger G=1, E=2, L=4, Ug=8, Ul=16, N=0, A = 31
      %constbytearray CC Map(0:23) = N,
               E,     L,   L!E,     G,   G!E, G!L!Ug!Ul,     A,     E,     N, N,
      {     BEQL,  BLSS,  BLEQ,  BGTR,  BGEQ,      BNEQ,   BRB,   BFS,   BFC,
               E,    Ul,  Ul!E,    Ug,  Ug!E, G!L!Ug!Ul,     A,     E,     N,
      {     BEQL, BLSSU, BLEQU, BGTRU, BGEQU,      BNEQ,   BRB,   BFS,   BFC,
               N,     N,     N,     N
      {      BBS,   BBC,  BLBS,  BLBC
      %false %if CC1&128 # 0 %or CC2&128 # 0
      M1 = CC Map(CC1)
      M2 = CC Map(CC2)
      %true %if M1 = M1&M2
      %false
   %end

%routine Absorb Jumps(%record(Blockfm)%name Head)
   %integer Mod
   %record(Itemfm)%name It

   %routine Absorb(%record(Itemfm)%name I)
      %record(Itemfm)%name Next, Dest, Else
      {I is known to be a conditional branch}
      Dest == I_Label                          {destination of the branch}
      ->NO %unless 0 <= Dest_Ca-I_Ca <= 24     {not too far away}
      ->NO %if Dest_Flags&Referenced # 0       {already in use} {???why???}
      Next == I_Link                           {skip safe things}
      %cycle
         ->NO %if Next == NIL
         %exit %unless Next_Type = Call Type                           -
                   %or (Next_Type = Prim Type %and Next_Prim # 22)     -
                   %or Next_Type = External Type                       -
                   %or Next_Type = Return Type
         %if Next_Type = Prim Type %start
            {BEWARE - prim changes the condition code}
            ->NO %if Next_Link ## Dest %or Next_Link_Ca # Next_Ca+4
         %finish
         Next == Next_Link
      %repeat
      %if Next == Dest %start               {IF ... THEN ... FI   }
                                            {^               ^    }
                                            {I           Next=Dest}
         I_Flags = I_Flags ! Absorbed       {make it go away}
         I_Cond  = Inverse(I_Cond)          {onto the TRUE condition}
         I_Ca = I_Ca+4                      {to compensate for MOD}
         Dest_Flags = Dest_Flags!Label Used {probably unnecessary now}
         Mod = Mod-4                        {we've removed 1 branch}
      %else %if Next_Type = Branch Type     {IF ... THEN ... ELSE ... FI   }
                                            {^               ^    ^   ^    }
                                            {I               Next Dest Else}
         ->NO %unless Next_Link == Dest          -
                 %and Next_Flags&Conditional = 0 -
                 %and Dest_Ca = Next_Ca+4
         Else == Dest_Link                  {skip safe things}
         %cycle
            ->NO %if Else == NIL
            %exit %unless Else_Type = Call Type     -
                      %or Else_Type = Prim Type     -
                      %or Else_Type = External Type -
                      %or Else_Type = Return Type
            %if Else_Type = Prim Type %start
               {BEWARE - prim changes the condition code}
               ->NO %if Else_Link ## Next_Label %or Else_Link_Ca # Else_Ca+4
            %finish
            Else == Else_Link
         %repeat
         ->NO %unless Else == Next_Label            -
                    %and 0 <= Else_Ca-Dest_Ca <= 24 -  {not too far away}
                    %and Else_Flags&Referenced = 0     {not otherwise used}
         I_Flags    =    I_Flags ! Absorbed
         Next_Flags = Next_Flags ! Absorbed
         Dest_Flags = Dest_Flags ! Label Used
         Else_Flags = Else_Flags ! Label Used
         Next_Cond  = I_Cond
         I_Cond     = Inverse(I_Cond)
         I_Ca = I_Ca+8                     {to compensate for MOD}
         Mod = Mod-8
      %finish
      %return
NO:   {mark the destination label as having been referenced}
      Dest_Flags = Dest_Flags ! Referenced
   %end

   It == Head_Items
   Mod = 0
   %while It ## Nil %cycle
      Absorb(It) %if It_Type = Branch Type %and It_Flags&Conditional # 0 -
                                           %and It_Flags&Absorbed = 0
      It_Ca = It_Ca+Mod
      It == It_Link
   %repeat
   Head_Code Size = Head_Code Size+Mod
%end

   %routine Process Block(%record(Blockfm)%name Head)
      %record(Itemfm)%name It, New, Next, Dest
      %record(Itemfm) Base
      %integer Mod, Altered, Here
      %cycle
         Mod = 0;  Altered = 0
         It == Head_Items
         %while It ## Nil %cycle
            Dest == It_Label
            Here = It_Ca
            Next == It_Link
            %if It_Flags&Absorbed # 0 %start
               Dest_Flags = Dest_Flags!Label Used
            %else %if It_Type = Branch Type
               %if    It_Flags&Conditional # 0    %and    {conditional jump}
                      Next ## Nil                 %and    {followed by ..}
                      Next_Ca = Here+4            %and    {something near}
                      Next_Type = Branch Type     %and    {a branch}
                      Next_Flags&Conditional = 0  %and    {which is uncond}
                      Next_Cond&128 = 0           %and    {not m-code}
                      Next_Link ## Nil            %and    {followed by ..}
                      Next_Link_Type = Label Type %and    {the first label}
                      Dest == Next_Link          %and
                      Next_Link_Ca = Here+8       %start

               ! Remove jumps around jumps

               ! X:   B true X+4
               ! X+4: B      Y
               ! X+4: ..........

               ! becomes

               ! X:   B false Y
               ! X+4: (deleted)

                  It_Cond = Inverse(It_Cond)
                  It_Label== Next_Label
                  Next_Flags = Deleted
                  It_Link == Next_Link
                  It_Ca = It_Ca+4              {to compensate for MOD}
                  Mod = Mod-4;  Altered = 1
                  It_Label_Flags = It_Label_Flags!Label Used

               %else %if Dest_Link ## Nil             %and
                         Dest_Link_Ca = Dest_Ca       %and
                         Dest_Link_Type = Branch Type %and
                         Dest_Link_Label ## Dest      %and
                         Compatible(It_Cond, Dest_Link_Cond)

               ! Remove jumps to jumps

               ! X:  B Y
               ! ..
               ! Y:  B Z

               ! Becomes

               ! X:  B Z
               ! ..
               ! Y:  B Z

                     It_Label == Dest_Link_Label
                     Altered = 1
                     It_Label_Flags = It_Label_Flags!Label Used

               %else %if It_Flags&Conditional = 0        %and
                         It_Cond&128 = 0                 %and
                         Next ## Nil                     %and
                         Next_Type = Branch Type

               ! X       B  fred
               ! X+n     B  jim

               ! is reduced to

               ! X       B fred

               ! as the jump at X+4 can never be reached (note that
               ! it has NO LABEL on it).

                  Next_Flags = Deleted;  Next == Next_Link
                  It_Ca = It_Ca+4 {to compensate for MOD}
                  Mod = Mod-4
                  Altered = 1
                  It_Label_Flags = It_Label_Flags!Label Used

               %else %if It_Label == It_Link %and It_Label_Ca = It_Ca+4

               ! REMOVE DEGENERATE JUMPS

               ! X       B jim
               ! X+4 jim:

               ! is reduced to

               ! X   jim:

               ! NB that this is done by marking for deletion
               ! which is performed in the label-reduction step
               ! later on.

                  Mod = Mod-4
                  It_Flags = Deleted
                  Altered = 1

               %else
                  It_Label_Flags = It_Label_Flags!Label Used     {mark used}
               %finish
            %else %if It_Type = Jump Type %or It_Type = Disp Type
               It_Label_Flags = It_Label_Flags!Label Used        {mark used}
            %finish
            It_Ca = It_Ca+Mod
            It == Next
         %repeat
         Head_Code Size = Head_Code Size+Mod
         %exit %if Altered = 0

         {remove unused compiler-defined labels and deleted items}

         New == Base
         It == Head_Items
         %while It ## Nil %cycle
            New_Link == It
            %if It_Type = Label Type %start
               %if It_Flags&(Marked!Label Used) # 0 %start
                  New == It                            {keep it}
                  It_Flags = It_Flags&(\Label Used)    {drop used bit}
               %else
                  It_Flags = Deleted
               %finish
            %else
               New == It %if It_Flags&Deleted = 0      {keep it}
            %finish
            It == It_Link
         %repeat
         New_Link == Nil
         Head_Items == Base_Link
      %repeat
      Absorb Jumps(Head)
   %end

   %routine Process Blocks
      %record(Blockfm)%name B
      B == Block List
      %while B ## Nil %cycle
         Process Block(B)
         B == B_Link
      %repeat
   %end

   %routine Stretch(%record(Blockfm)%name Head)
      {the global BIAS is updated}
      %record(Itemfm)%name It
      %integer Here, Mod, Disp, Type
      %switch T(Label Type:Final Type)
      Mod  = Bias;  Bias = 0
      Head_Code Base = Head_Code Base+Mod
      Head_Body      = Head_Body+Mod
      Head_Ca        = Head_Ca+Mod
      Head_Label_Ca  = Head_Ca
      Head_Code Size = Head_Code Size-Mod         {to correct for final addition}
      It == Head_Items
      %while It ## Nil %cycle
         Here = It_Ca
         It_Ca = It_Ca+Mod                        {relocate it}
         Type = It_Type
         ->T(Type)

T(*):       CSR("Corrupt item type".ItoS(It_Type, 1))

T(Addr Type):  ->Next %if It_Flags&Long # 0
               Disp = (It_Ca+8+Mod)-(Area Base_Constant+It_Value)
               %unless 16_FFFF8000 <= Disp <= 16_0000 7FFF %start
                  It_Flags = It_Flags ! Long
                  Mod = Mod+4
               %finish
               ->Next

T(Caddr Type): ->Next %if It_Flags&VeryLong # 0
               Disp = (It_Ca+8+Mod)-(Area Base_Constant+It_Value)
               Disp = Disp>>2 %if Disp&3 = 0   {will be scaled when loaded}
               %unless Disp <= 255 %start
                  %if It_Flags&Long = 0 %start
                     It_Flags = It_Flags ! Long
                     Mod = Mod+4
                     {Disp = M<<8 + N}
                     {ADD _ R, Pc, #M<<8}
                     {LDR _ R, [R, #N]}
                  %else %if Disp > 16_FFFF
                     It_Flags = It_Flags ! VeryLong
                     Mod = Mod+4
                     {Disp = L<<16 ! M<<8 ! N}
                  %finish
               %finish
               ->Next

T(Rload Type): ->Next %if It_Flags&VeryLong # 0
               Disp =((It_Ca+8+Mod)-(Area Base_Constant+It_Value))>>2
               %unless Disp <=  255 %start
                  %if It_Flags&Long = 0 %start
                     It_Flags = It_Flags ! Long
                     Mod = Mod+4
                     {Disp = M<<8 + N}
                     {SUB _ R, Pc, #M<<(8+2)}
                     {LDR _ R, [R, #N]}
                  %else %if Disp > 16_FFFF
                     It_Flags = It_Flags ! VeryLong
                     Mod = Mod+4
                     {Disp = X<<16 ! M<<8 ! N}
                  %finish
               %finish
               ->Next

T(Cload Type): ->Next %if It_Flags&VeryLong # 0
               Disp = (It_Ca+8+Mod)-(Area Base_Constant+It_Value)
               %unless Disp <= 4095 %start
                  %if It_Flags&Long = 0 %start
                     It_Flags = It_Flags ! Long
                     Mod = Mod+4
                     {Disp = M<<12 + N}
                     {ADD _ R, Pc, #M<<12}
                     {LDR _ R, [R, #N]}
                  %else %if Disp > 16_FF FFF
                     It_Flags = It_Flags ! VeryLong
                     Mod = Mod+4
                     {Disp = X<<20 ! M<<12 ! N}
                  %finish
               %finish
               ->Next

T(Thunk Type):
T(Sload Type):
T(Disp Type):
T(Jump Type):
T(Prim Type):
T(Branch Type):
T(Call Type):
T(External Type): ->Next


T(Return Type):

          %if It_Flags&Minimum # 0 %start
             It_Flags = It_Flags-Minimum
             Mod = Mod+Head_Return
          %finish
          ->Next

T(Label Type):

Next:    It == It_Link
      %repeat
      Head_Code Size = Head_Code Size+Mod
      Bias = Bias+Mod
   %end

   %routine Stretch blocks
      %record(Blockfm)%name B
      %cycle
         Bias = 0
         B == Block List
         Stretch(B) %and B == B_Link %while B ## Nil
         Area Size_Code  = Area Size_Code+Bias  {new actual size}
         Xentry Base = Xentry Base+Bias
         Extra Base = Extra Base + Bias
         Code Size = Code Size + Bias
      %repeat %until Bias = 0
   %end

   %routine Mark Forward
      %record(Blockfm)%name B
      %record(Itemfm)%name I
      B == Block List
      %while B ## Nil %cycle
         I == B_Items
         %while I ## Nil %cycle
            %if I_Type >= Branch Type %start
               I_Flags = I_Flags ! Forward %if I_Label_Ca > I_Ca
            %finish
            I == I_Link
         %repeat
         B == B_Link
      %repeat
   %end

   %routine Allocate(%record(Blockfm)%name B, %integer At)

      { <...pre-entry sequence...> <ENTER...><entry sequence> <body>}
      {     ^                       ^                               }
      {     Code Base               Ca                              }

      %integer Extra = 0, Frame, N, Amod = 0
      %record(Itemfm)%name It
      B_Code Base = At
      Amod = 4                               {block flags, display & link}

      Extra = 4 %and ->OK %if B == Entry Head

      %if B_Flags&No Entry = 0 %start
         Amod = Amod+12 %if B_Event Mask # 0 {Mask, Limit, Ep}
         Frame = -B_Frame
         Extra = Extra+8                          {STM, MOV}
         %if B_Attr&Attr Xdef # 0 %start          {set up SB}
            %if B_Attr&Attr Needs Gp # 0 %start
               Amod = Amod+4                      {SB pointer}
               %if B_Attr&Attr Both = 0 %start
                  Extra = Extra+4                 {LDR _ Sb, []}
               %else
                  Extra = Extra+8                 {LDR, R7, []; MOV Sb, R7}
               %finish
            %finish
         %finish
         %if B_Attr&Attr Both # 0 %start
            Extra = Extra + 8                     {LRD _ R7, Olddisplay & STR}
            B_Return = B_Return+8
         %finish

         %if Options&LL Assigned # 0 %start
            N = Frame>>2     {words to set unassigned}
            %if N # 0 %start
               Extra = Extra+4           {needs one load instruction}
               %if N <= 4 %start
                  Extra = Extra+4        {only one store}
               %else
                  %if N&3 # 0 %start
                     Extra = Extra+4     {one store for the remainder}
                     N = N&(\3)
                  %finish
                  N = N>>2               {now in fours}
                  %if N <= 5 %start
                     Extra = Extra + 4*N {one store each}
                  %else
                     Extra = Extra+12    {load count, decrement & branch}
                     %cycle              {calculate size of LOAD instrn}
                        N = N>>2 %while N&3 = 0
                        Extra = Extra+4
                        N = N>>8
                     %repeat %until N = 0
                  %finish
               %finish
            %finish
         %else
            N = Frame
            %while N # 0 %cycle
               N = N>>2 %while N&3 = 0
               Extra = Extra+4
               N = N>>8
            %repeat
         %finish

         Extra = Extra+4
         Extra = Extra+4 %if B_Pframe # 0
      %finish
 OK:  At = At+Amod                                {pre-entry sequence}
      B_Code Size = B_Code Size+Extra+Amod
      B_Ca        = At
      B_Label_Ca  = At
      At = At+Extra                               {entry sequence}
      B_Body      = At

      It == B_Items                               {relocate labels & jumps}
      %while It ## Nil %cycle
         It_Ca = It_Ca+At %unless It_Type = Array Disp Type
         It == It_Link
      %repeat
   %end

 %routine Allocate Blocks
      %integer Dp, Cp, N

      %record(Blockfm)%name B

      Area Size_Code = 0
      N = (Length(Interface_Module) + 1 + 1 + 3)&(\3)
      Area Size_Block = N + 4 + 4*Number of Blocks + 4 {environs} + 4 {MARK}
      Area Size_Block = 4 %if Options&LL Trace = 0

      Area Size_Record = Record Size
      Area Size_Record = 0 %if Options&LL Records = 0
      Area Size_Diag   = 0 %if Options&LL Vars    = 0
      Area Size_Line   = 0 %if Options&LL Lines   = 0

      Area Size_Global  = Max SB-Min SB
      Area Size_Diag    = (Area Size_Diag+3)&(\3) + (Area Size_Line+3)&(\3)
      Area Size_Record  = (Area Size_Record+3)&(\3)

      Area Base_Diag    = 0
      Area Base_Diag    = 4 %if Main Program # 0           {ref to ?___ENTRY_POINT}
      Area Base_Record  = Area Base_Diag     + Area Size_Diag
      Area Base_Constant= Area Base_Record   + Area Size_Record
      Area Base_Block   = Area Base_Constant + Area Size_Constant
      Area Base_Code    = Area Base_Block    + Area Size_Block

      Area Base_Global  = 0
      Area Base_Global Array = Area Size_Global

      Data Size = (Area Size_Global  + Area Size_Global Array + 3)&(\3)
      Data Size = 4 %if Data Size = 0      {Sad - but can't have empty areas}

      Cp = Area Base_Code;  Dp = Area Base_Diag

      B == Block List
      %while B ## Nil %cycle
         Allocate(B, Cp)
         B_Diag Base = Dp
         B_Line Base = Dp + B_Diag Size
         Dp = Dp + B_Diag Size + B_Line Size
         Cp = Cp + B_Code Size
         B == B_Link
      %repeat
      Extra Base = Cp
      Xentry Base = Cp
      Code Size      = Xentry Base + Xentry
      Area Size_Code = Code Size - Area Base_Code
   %end

   %routine Allocate Debug Information(%record(ProcedureFm)%name P)  {001}
      %integer Dummy = 0
      %integer Disp = 0
                                                                  {001}
      {First, calculate size of debug area}                       {001}
                                                                  {001}
      %routine Allocate Var(%record(DvarFm)%name V, %integername Args)
         %return %if V_Class = -1
         Disp = Disp+W + 4*W + Padded(V_Ident)
         Args = Args+1 %if V_Class = 3 %and V_Offset > 0 {a parameter}
      %end

      %routine Allocate Variables(%record(DvarFm)%name Z, %integername Args)
         %record(DvarFm)%name D
         D == Z
         %if D ## NIL %start
            %cycle
               D == D_Link
               Allocate Var(D, Args)
            %repeat %until D == Z
         %finish
      %end

      %routine Allocate Format(%record(Dformatfm)%name F)
         %record(DvarFm)%name V, Z
         F_Bytes  = 0
         F_Disp   = Disp
         F_Fields = 0
         F_Size   = W + 2*W
         Z == F_Vars
         V == Z
         %if V ## NIL %start
            %cycle
               F_Fields = F_Fields+1
               F_Bytes  = F_Bytes+V_Size
               F_Size   = F_Size + 2*W + Padded(V_Ident)
               V == V_Link
            %repeat %until V == Z
         %finish
         %if F_Fields = 1 %and F_Vars_Class = -1 %start  {really an array}
            F_Size = W + 5*W
            F_Fields = -1
         %finish
         Disp = Disp+F_Size
      %end

      %routine Allocate Formats(%record(DformatFm)%name Z)
         %record(DFormatFm)%name D
         D == Z
         %if D ## NIL %start
            %cycle
               D == D_Link
               Allocate Format(D)
            %repeat %until D == Z
         %finish
      %end

      %routine Allocate Procedures(%record(Procedurefm)%name P)   {001}
         %cycle
            %return %if P == NIL                                  {001}
            Disp = Disp + 8*W + Padded(P_Name)
            %if Debug Options&2 = 0 %start
               Allocate Formats(P_Formats)
               Allocate Variables(P_Vars, P_Args)
            %finish
            Allocate Procedures(P_Inner)
            P_EndItem = Disp
            Disp = Disp + 5*W + 4*P_Nreturns                      {001}
            P == P_Next
         %repeat
      %end                                                        {001}
                                                                  {001}
      %routine Allocate Files(%record(Filefm)%name F)
         %integer N = 0, Size, Fsize
         %record(FragmentFm)%name Fr, X

         %integerfn Frag Size(%record(FragmentFm)%name F)

            %integerfn LineNo Size(%record(DLinefm)%name L)
               %integer Size = 0

               %routine Count(%integer LineInc, CodeInc)
                  %return %if LineInc < 0 %or CodeInc <= 0
                  Size = Size+2
                  Size = Size+4 %if LineInc > 255 %or CodeInc > 255
               %end

               %result = 0 %if Debug Options&1 # 0
               %result = 0 %if L == NIL
               %cycle
                  %exit %if L_Link == NIL   {this is the last line}
                  Count(L_Link_Line-L_Line, L_Link_Ca-L_Ca)
                  L == L_Link
               %repeat
               Count(F_To-L_Line, F_Code+F_CodeSize-L_Ca)
               %result = Size
            %end

            F_Size = 5*W + LineNo Size(F_Lines)
            F_Padding = F_Size&2
            F_Size = F_Size+F_Padding
            %result = F_Size
         %end

         %routine Merge(%record(FragmentFm)%name A, B)
            %record(Dlinefm)%name L
            {Fragment B follows immediately from A}
            {combine them - be careful with line-no info}
            A_To = B_To
            A_CodeSize = A_CodeSize+B_CodeSize
            %if A_Lines == NIL %start
               A_Lines == B_Lines
            %else %if B_Lines ## NIL
               L == A_Lines
               L == L_Link %while L_Link ## NIL
               L_Link == B_Lines
            %finish
         %end

         %integerfn File Size(%record(Filefm)%name F)
            %integer Size, N
            %record(FragmentFm)%name A, B

            {First, reverse the list and try to merge fragments}
            A == F_Frag;  F_Frag == NIL
            %while A ## NIL %cycle
               B == A
               A == B_Link
               %continue %if B_From = 0 %or B_To = 0   {empty item}
               %if A_To+1 = B_From %and A_Code+A_CodeSize = B_Code %start
                  Merge(A, B)
                  %continue
               %finish
               B_Link == F_Frag
               F_Frag == B
            %repeat

            {Now, calculate the size}
            Size = 3*W + Padded(F_File)
            N = 0

            A == F_Frag
            %while A ## NIL %cycle
               Size = Size+Frag Size(A)
               N = N+1
               A == A_Link
            %repeat
            F_N = N
            F_Size = Size
            %result = Size
         %end

         Files Size = 4               {code word}
         %if Debug Options&4 = 0 %start
            %while F ## NIL %cycle
               F_Disp = Disp+Files Size
               Files Size = Files Size+File Size(F)
               F == F_Link
            %repeat
         %finish
         Files Size = Files Size+4    {terminator}
         Disp = Disp+Files Size
      %end

      Disp = 4 + 1 + 2 + 1 + 6*W + Padded(Interface_Module)       {001}
      %if Debug Options&2 = 0 %start
         Allocate Formats(Fglobals)
         Allocate Variables(Dglobals, Dummy)
      %finish
      Allocate Procedures(P)    {procedure information}           {001}
      Allocate Files(DebugFiles)
      Bugs Size = Disp
      CSR("Debug alignment") %if Bugs Size&3 # 0
   %end                                                           {001}

   %routine Allocate Buffer(%integer Segment, Size)               {001}
      %integer N
      CSR("Null Area") %if Size <= 0
      N = Get Space(Size)                                         {001}
      Segment  Base(Segment) = N                                  {001}
      Segment Limit(Segment) = N+Size                             {001}
   %end                                                           {001}

   %routine Dump Block(%integer Level, Finish, InPrim, %integername DebugA)  {001}
      %routinespec Dump(%integer B)
      %constbytearray Branch(0:23) = 16_FA,
      {                                BNV
           16_0A, 16_BA, 16_DA, 16_CA, 16_AA, 16_1A, 16_EA, 16_1A, 16_0A, 0,
      {     BEQL,  BLSS,  BLEQ,  BGTR,  BGEQ,  BNEQ,   BRB,   BFS,   BFC,
           16_0A, 16_3A, 16_9A, 16_8A, 16_2A, 16_1A, 16_EA, 16_1A, 16_0A,
      {     BEQL, BLSSU, BLEQU, BGTRU, BGEQU,  BNEQ,   BRB,   BFS,   BFC,
           16_FA, 16_FA, 16_FA, 16_FA
      {      BNV,   BNV,  BNVS,   BNV

      %switch D(1 : Max Dir)                                       {002}
      %integer Code Basis,
               Line Basis,
               Diag Basis
      %integer Code, N, M, Frame, Display, Disp, Lb, Ub, Work, Op, C
      %integer At, Set CC = 0
      %integer Wanted, Xxx, Bflags
      %integer Record Diags = 0
      %integer   Rel1 No, Rel2 No, Rel3 No                        {001}
      %owninteger Entry Reference = 0

      %record(Itemfm)%name Item, CC Label == NIL
      %record(Blockfm)%name Head
      %record(Linefm) Line Info = 0
      %record(Xfm)%name X
      %integer D1, D2
      %record(Procedurefm) Debug Base                             {001}
      %record(Procedurefm)%name DebugP == NIL,                    {001}
                                Debug List == Debug Base          {001}
      %record(DFormatPFm)%name Dfm == NIL


      %routine Dump Cstring (%string(255) S, %integer N)
        %integer J
        %if N # 0 %start              {add null}
           S = S.Tostring(0)
           %if N = 2 %start           {round up to multiple of 4}
              S = S.Tostring(0) %while Length(S)&3 # 0
           %finish
        %finish
        Printsymbol(Charno(S, J)) %for J = 1, 1, Length(S)
      %end

      %routine Select Diag Area
        Ca == Diag Basis
        Select(CSeg, Ca)
      %end

      %routine Select Record Area
        Ca == Record Basis
        Select(CSeg, Ca)
      %end

      %routine Select Line Area
        Ca == Line Basis
        Select(CSeg, Ca)
      %end

      %routine Select Code Area
         Ca == Code Basis
         Select(CSeg, Ca)
      %end

      %routine Select Debug Area
         Ca == Bugs Basis
         Select(BSeg, Ca)
      %end

      %routine Select Pure Area(%integer Bias)
         Ca == Other Basis
         Ca = Bias
         Select(CSeg, Ca)
      %end

      %routine Enter Line Diagnostic
         %integer Nl = Line Info_Line - Line Info_Last Line,
                  Nc = Line Info_Ca   - Line Info_Last Ca-4
         %return %if Nl <= 0 %or Nc <= 0   {treat it as one line}
         Select Line Area
         %if Nl > 1 %start
            Nl = Nl-2
            %if Nl >= 64 %start
               Dump((Nl<<2)&255+2_11)
               Dump(Nl>>6)
            %else
               Dump(Nl<<2+2_10)
            %finish
         %finish
         %if Nc >= 64 %start          {big CA}
            Dump((Nc<<2)&255+2_01)
            Dump(Nc>>6)
         %else                        {small CA}
            Dump(Nc<<2 + 2_00)
         %finish
         Select Code Area
         Line Info_Last Ca   = Ca
         Line Info_Last Line = Line Info_Line
         Line Info_Pending   = 0
      %end

      %routine Dump(%integer N)
         Enter Line Diagnostic %if Line Info_Pending # 0 -
                              %and Line Info_Ca = Ca     -
                              %and Ca == Code Basis
         Byte(Current Address) = N
         Current Address = Current Address + 1
         %if Current Address > Current Limit %start
            A Error(Current Address, Current Limit)
         %finish
         Ca = Ca+1
      %end

      %routine Dump2(%integer N)
         Enter Line Diagnostic %if Line Info_Pending # 0 -
                              %and Line Info_Ca = Ca     -
                              %and Ca == Code Basis
         Byte(Current Address+0) = (N>>0)&255
         Byte(Current Address+1) = (N>>8)&255
         Current Address = Current Address + 2
         %if Current Address > Current Limit %start
            A Error(Current Address, Current Limit)
         %finish
         Ca = Ca+2
      %end

      %routine Dump4(%integer N)
         Enter Line Diagnostic %if Line Info_Pending # 0 -
                              %and Line Info_Ca = Ca     -
                              %and Ca == Code Basis
         %if Set CC # 0 %and Ca == Code Basis %start
             CSR("Bad cc to change") %unless N>>28 = 16_E
             N = N !! (Set CC<<24)
         %finish
         Byte(Current Address + 0) = (N>>00)&255
         Byte(Current Address + 1) = (N>>08)&255
         Byte(Current Address + 2) = (N>>16)&255
         Byte(Current Address + 3) = (N>>24)&255
         Current Address = Current Address + 4
         %if Current Address > Current Limit %start
            A Error(Current Address, Current Limit)
         %finish
         Ca = Ca + 4
      %end

      %routine Dump4bytes(%integer N)
         Printsymbol(N&255)
         Printsymbol(N>>8&255)
         Printsymbol(N>>16&255)
         Printsymbol(N>>24&255)
      %end

      %integerfn External Index(%record(Xfm)%name X)
         {This function returns an index into the symbol table}
         {corresponding to the external object X}
         %integer At, Value, Area
         %if X_Flags & Ext Dumped = 0 %start         {not yet in symbol table}
            X_Flags = X_Flags ! Ext Dumped
            %if X_Flags&Ext Defn # 0 %start          {external definition}
               At = 2_0011
               %if X_Flags&Ext Code # 0 %start       {code definition}
                  Value = Items(X_Disp)_Ca
                  Area = CodeArea
               %else                                 {data definition}
                  Value = X_Disp-Min SB
                  Area = DataArea
               %finish
            %else                                    {external reference}
               At = 2_0010
               Value = 0;  Area = DataArea           {the VALUE field is not needed}
            %finish
            X_Value = Symbol Entry(X_Flags>>8, At, Value, Area)
         %finish
         %result = X_Value
      %end

      %routine Relocate(%integer Data, Segment, Xindex, Mode)
         ! Mode: SymbolReloc, PcReloc
         %record(Relocfm)%name R
         %record(SegmentRfm)%name Sr
         %integer Displacement = Ca
         Displacement = Displacement-Min SB %if Segment = DSeg
         Dump4(Data)
         R == NEW(Relocfm Type)
         R_Vaddr = Displacement
         R_Code  = Xindex ! Mode<<16
         Sr == Segment Reloc(Segment)
         R_Link == Sr_R;  Sr_R == R
         Sr_Entries = Sr_Entries+1
      %end

      %routine Dump Header
         %integer Len,  N, Areas
         %string(63) Compiler = ProductCode.":".Version.".".Release.".".Revision

         %integer Chunk Offset

         %routine Chunk Entry(%string(8) Id, %integer Size)
            Dump Cstring(Id, 0)
            %if Size = 0 %start
               Dump4Bytes(0)          {zero offset for not-in-use}
               Dump4Bytes(0)          {zero size too}
            %else
               Dump4Bytes(Chunk Offset)
               Dump4Bytes(Size)
               Chunk Offset = Chunk Offset + Size
            %finish
         %end

         Areas = 2
         Areas = 3 %if Debug # 0

         N = Code Size;  CSR("Bad alignment") %if N&3 # 0
         Len = (Length(Compiler) + 4)&(\3)
         Header Size = 6*4 + 5*4*Areas

         SymTsize   = (Symbol Entry No+1)*16
         ActiveSize = Code Size + Data Size + Bugs Size -   {001}
                                + (Rel1No+Rel2No+Rel3No)*8  {001}
         String Size = (String Size+3)&(\3)
         Total Size = 16_8C + Header Size + Len -
                            + String Size + SymTSize + Active Size

         Open Object File(Total Size)
         Select Output(Object Out)

         Dump4bytes(16_C3CB C6C5)               {chunk header}
         Dump4bytes(8)                          {max no. chunks}
         Dump4bytes(5)                          {actual no. chunks}

         Chunk Offset = 16_8C                   {size of chunk header}
         Chunk Entry("OBJ_HEAD", Header Size)   {object header}
         Chunk Entry("OBJ_IDFN", Len)           {identification}
         Chunk Entry("OBJ_STRT", String Size)   {string table}
         Chunk Entry("OBJ_SYMT", SymTsize)      {symbol table}
         Chunk Entry("OBJ_AREA", ActiveSize)    {code & data areas}
         Chunk Entry("OBJ_UNU1", 0)
         Chunk Entry("OBJ_UNU1", 0)
         Chunk Entry("OBJ_UNU1", 0)

         {header chunk}

         Dump4bytes(16_C5E2D080)            {obj_header}
         Dump4bytes(AOF Version)                             {001}
         Dump4bytes(Areas)                  {no. of areas}
         Dump4bytes(Symbol Entry No+1)      {no. of symbols}
         %if Entry Head == Nil %start       {no entry address}
            Dump4bytes(0)
            Dump4Bytes(0)
         %else                              {an entry address}
            Dump4bytes(1)                   {first area is code area}
            Dump4bytes(Entry Head_Label_Ca)
         %finish

         {area declarations}

         %routine Declare Area(%integer Name Offset, AtAl, Size, Rels)
            Dump4bytes(Name Offset)            {offset for area name}
            Dump4bytes(AtAl)                   {at,al}
            Dump4bytes(Size)                   {size of area}
            Dump4bytes(Rels)                   {no. of relocations}
            Dump4bytes(0)                      {base addr}
         %end

         Declare Area(CodeArea, 16_2202, Code Size, Rel1 No) {Bit5+Bit2}
         Declare Area(DataArea, 16_0002, Data Size, Rel2 No) {no bits}
         %if Debug # 0 %start
            Declare Area(DbugArea, 16_A002, Bugs Size, Rel3 No) {Bit7+Bit5}    {001}
         %finish

         {identification chunk}

         Dump Cstring(Compiler, 2)             {obj_idfn}
      %end

      %routine Dump Strings
         %integer P = User String Base
         %record(Usefm)%name U
         %record(Xfm)%name X

         Dump4Bytes(String Size)
         Dump Cstring("$CODEAREA", 1)  {set up AREA names}
         Dump Cstring("$DATAAREA", 1)
         Dump Cstring("$DBUGAREA", 1) %if Debug # 0
         Dump Cstring(Main Entry Id, 1) %if Main Program # 0

         U == Total Uses
         %while U ## NIL %cycle
            X == U_X
            %if X ## NIL %start
               CSR("shuffled strings") %unless P = X_Flags>>8
               P = P+Length(X_Text)+1
               Dump Cstring(X_Text,1)
            %finish
            U == U_Link
         %repeat
         Printsymbol(0) %and P = P+1 %while P&3 # 0
         CSR("corrupt string table") %if P # String Size
      %end

      %routine Dump Symbols
         %record(Symbolfm)%name S
         Symbol List_Link == NIL
         S == Symbol Base_Link
         %while S ## NIL %cycle
            Dump4Bytes(S_Name)
            Dump4Bytes(S_Attributes)
            Dump4Bytes(S_Value)
            Dump4Bytes(S_Area)
            S == S_Link
         %repeat
      %end

      %routine Dump Relocation(%integer S)
         %record(Relocfm)%name R
         R == Segment Reloc(S)_R
         %while R ## NIL %cycle
            Dump4bytes(R_Vaddr)     {virtual address of reference}
            Dump4bytes(R_Code)      {index into symbol table}
            R == R_Link
         %repeat
      %end

      %routine Dump Segment(%integer N)
         %integer P
         Printsymbol(Byte(P)) %for P = Segment Base(N), 1, Segment Limit(N)-1
      %end

      %routine Dump Branch(%integer Op, Dest)
         %integer Disp = (Dest-Ca-8)>>2
         Dump4(Op<<24 ! Disp&16_00FF FFFF)
      %end

      %routine Next Prim(%integer Fn)
         Ip = Ip+1;  Item == Items(Ip)
         CSR("corrupt Prim") %unless Item_Type = Prim Type
         %return %if Wanted = 0
         Dump Branch(Fn, Item_Label_Ca)
      %end

      %routine Update Line
         Set Debug Line(Ca, Current Line)
         %return %if Options&LL Lines = 0      -
                 %or Head_Attr&Attr Prim # 0   -
                 %or Head_Line Size = 0
         Line Info_Line    = Current Line;  Line Info_Ca = Ca
         Line Info_Pending = 1
      %end

      %predicate Dumping Diags(%string(255) Id)
         {"" is a special to terminate}
         %integer J, L
         %false %if Head_Flags&Used = 0     -
                %or Head_Diag Size  = 0     -
                %or Head_Attr&Attr Prim # 0
         %if Record Diags = 0 %start     {normal variables}
            %false %if Options&LL Vars = 0
            Select Diag Area
         %else                           {record subfields}
            %false %if Options&LL Records = 0
            Select Record Area
         %finish
         L = Length(Id)
         Dump(L);  Dump(Charno(Id, J)) %for J = 1, 1, L
         %true
      %end

      %routine Dump Diag Entry
         %string(127) Id                          {002}
         %integer N, Key, L, F = 0, Type, Xtype
         Get String(Id, 127);  L = Length(Id)     {002}
         Key = Encoded Value;  Type = Key>>2&15
         Xtype = Encoded Value
         N   = Encoded Value
         F   = Encoded Value %if Key&64 # 0
         %return %unless Dumping Diags(Id)
         %if Key # 0 %start
            Dump(Key)
            Dump(Xtype) %if Xtype # 0
            %if -64 <= N <= 63 %start
               Dump(N&16_7F)
            %else %if 16_FFFF E000 <= N <= 16_0000 1FFF
               Dump((N>>8)&16_3F ! 2_10 000000)
               Dump(N&255)
            %else
               Dump((N>>24)&16_3F ! 2_11 000000)
               Dump(N>>16&255)
               Dump(N>>8&255)
               Dump(N&255)
            %finish
            %if Key&64 # 0 %start
               F = Formpt(F) %if F&16_8000 = 0
               Dump2(F&16_FFFF)
            %finish
         %finish
         Select Code Area
      %end

      %record(Itemfm)%map Next Item(%integer Type)
         %record(Itemfm)%name I
         Ip = Ip+1
         I == Items(Ip)
         %result == I %if I_Type = Type
         CSR("corrupt item type")
      %end

      %routine Update Include(%string(255) S)
         %recordformat Sfm(%record(Sfm)%name Link, %integer Line, %string(127) S)
         %constrecord(Sfm)%name Stype == 0
         %record(Sfm)%name Sl
         %ownrecord(Sfm)%name List == 0
         %if S = "" %start     {end of include file}
            Sl == List
            CSR("badly nested includes") %if Sl == Nil
            List == Sl_Link
            Included File = Sl_S
            Debug Include(S, Ca, Sl_Line+1)
            DISPOSE(Sl)
         %else
            Sl == NEW(Stype)
            Sl_S = Included File
            Sl_Link == List
            Sl_Line = Current Line
            List == Sl
            Included File = S
            Debug Include(S, Ca, 1)
         %finish
         Included File = Interface_Source File %if Included File = ""
      %end

      %routine Dump Debug Information(%record(Procedurefm)%name P){001}

         %routine Reloc(%integer Value, Area)
            %record(Relocfm)%name     R == NEW(Relocfm Type)
            %record(SegmentRfm)%name Sr == Segment Reloc(Bseg)
            R_Vaddr = Ca
            R_Code  = Area ! SymbolReloc<<16
            R_Link == Sr_R;  Sr_R == R
            Sr_Entries = Sr_Entries+1
            Dump4(Value)
         %end

         %routine Dump Debug String(%string(255) S)               {001}
            %integer J, L                                         {001}
            L = Length(S)                                         {001}
            Dump(L)                                               {001}
            Dump(Charno(S, J)) %for J = 1, 1, L                   {001}
            %cycle                                                {001}
               L = L+1                                            {001}
               %exit %if L&3 = 0                                  {001}
               Dump(0)                                            {001}
            %repeat                                               {001}
         %end                                                     {001}

         %routine Dump Section
            %integer N = 4+ 1+2+1+6*W + Padded(Interface_Module)     {001}
            %integer Flags
            Flags = 0
            Flags = Flags ! Source and Line Flag %if Debug Options&1 = 0
            Flags = Flags ! Variable Name Flag   %if Debug Options&2 = 0
            Dump4(N<<16 ! Debug Section)
            Dump(Language Pascal)         { 0:language}
            Dump2(Flags)                  { 1:sectionflags}
            Dump(1)                       { 3:debugversion}
            Reloc(0, Cseg)                { 4:codeaddr}
            Reloc(0, Dseg)                { 8:dataaddr}
            Dump4(Code Size)              { C:codesize}
            Dump4(Data Size)              {10:datasize}
            Dump4(Bugs Size-Files Size)   {14:fileinfo}
            Dump4(Bugs Size)              {18:debugsize}
            Dump Debug String(Interface_Module)
         %end

         %routine Dump Var(%record(DvarFm)%name V)
            %integer Size = W + 4*W + Padded(V_Ident)
            %integer Type = V_Type, I
            %if Type < 0 %start               {a record}
               I = Type&255
               Type = (Type>>8) ! 16_FF000000 {propagate sign-bit}
               Type = (-DebugFm(-Type)_F_Disp)<<8 ! I
            %finish
            Dump4(Size<<16 ! Debug Variable)
            Dump4(Type)                         {Type}
            Dump4(V_SourcePos)                  {Sourcepos}
            Dump4(V_Class)                      {Storage class}
            %if V_Class = 2 %start              {Static}
               Reloc(V_Offset, Dseg)            {Absolute location}
            %else                               {other}
               Dump4(V_Offset)                  {relative location}
            %finish
            Dump Debug String(V_Ident)          {name}
         %end

         %routine Dump Variables(%record(DvarFm)%name Z)
            %record(DvarFm)%name D
            D == Z
            %if D ## NIL %start
               %cycle
                  D == D_Link
                  Dump Var(D)
               %repeat %until D == Z
            %finish
         %end

         %routine Dump Format(%record(DformatFm)%name F)
            %record(DvarFm)%name V, Z
            %record(ArrayFm)%name A
            %if F_Fields = -1 %start        {special for arrays}
              Dump4(F_Size<<16 ! Debug Array)
              A == F_Vars_Array
              Dump4(A_Total)
              Dump4(2_1010)
              Dump4(A_Type)
              Dump4(A_Lower)
              Dump4(A_Upper)
              %return
            %finish
            Dump4(F_Size<<16 ! Debug Struct)
            Dump4(F_Fields)
            Dump4(F_Bytes)

            {Dump the fields}
            Z == F_Vars
            V == Z
            %if V ## NIL %start
               %cycle
                  V == V_Link
                  Dump4(V_Offset)             {Offset}
                  Dump4(V_Type)               {Type}
                  Dump Debug String(V_Ident)  {Name}
               %repeat %until V == Z
            %finish
         %end

         %routine Dump Formats(%record(DformatFm)%name Z)
            %record(DFormatFm)%name D
            D == Z
            %if D ## NIL %start
               %cycle
                  D == D_Link
                  Dump Format(D)
               %repeat %until D == Z
            %finish
         %end

         %routine Dump Procedures(%record(Procedurefm)%name P)    {001}
            %integer N, X                                         {001}
            %record(PreturnFm)%name R
            %while P ## NIL %cycle                                {001}
               N = 4+ 4*7 + Padded(P_Name)                        {001}
               Dump4(N<<16 ! Debug Procedure)                     {001}
               Dump4(P_Type)                                      {001}
               Dump4(P_Args)                                      {001}
               Dump4(P_StartPos)                                  {001}
               Reloc(P_Proc_Ca, Cseg)                             {001}
               Reloc(P_Proc_Body, Cseg)                           {001}
               Dump4(P_EndItem)                                   {001}
               Dump4(P_StartFile_Disp)                            {001}
               Dump Debug String(P_Name)                          {001}
               %if Debug Options&2 = 0 %start
                  Dump Formats(P_Formats)
                  Dump Variables(P_Vars)
               %finish
               Dump Procedures(P_Inner)                           {001}
               X = P_Nreturns
               N = 4+ 4*4 + 4*X                                   {001}
               Dump4(N<<16 ! Debug Endproc)                       {001}
               Dump4(P_EndPos)                                    {001}
               Reloc(P_Proc_Code Base+P_Proc_Code Size, Cseg)     {001}
               Dump4(P_EndFile_Disp)                              {001}
               Dump4(X)                                           {001}
               R == P_Return
               %while R ## NIL %cycle
                  Reloc(R_Ca, Cseg)
                  X = X-1
                  R == R_Link
               %repeat
               Csr("Missing returns") %if X # 0
               P == P_Next                                        {001}
            %repeat                                               {001}
         %end                                                     {001}

         %routine Dump Fileinfo                                   {001}
            %record(Filefm)%name F

            %routine Dump Line(%integer LineInc, CodeInc)
               %if LineInc > 255 %or CodeInc > 255 %start
                  Dump2(0)
                  Dump2(LineInc);  Dump2(CodeInc)
               %else %if CodeInc > 0 %and LineInc >= 0
                  Dump(CodeInc);  Dump(LineInc)
               %finish
            %end

            %routine Dump Fragment(%record(FragmentFm)%name F)
               %record(DlineFm)%name L
               Dump4(F_Size)
               Dump4(F_From)
               Dump4(F_To)
               Reloc(F_Code, Cseg)
               Dump4(F_CodeSize)
               %return %if Debug Options&1 # 0
               L == F_Lines
               %return %if L == NIL
               %while L_Link ## NIL %cycle
                  Dump Line(L_Link_Line-L_Line, L_Link_Ca-L_Ca)
                  L == L_Link
               %repeat
               Dump Line(F_To-L_Line, F_Code+F_CodeSize-L_Ca)
               Dump2(16_0101) %if F_Padding # 0
            %end

            %routine Dump File(%record(Filefm)%name F)
               %record(FragmentFm)%name Fr
               Dump4(F_Size)
               Dump4(0)            {date}
               Dump Debug String(F_File)
               Dump4(F_N)
               Fr == F_Frag
               %while Fr ## NIL %cycle
                  Dump Fragment(Fr)
                  Fr == Fr_Link
               %repeat
            %end

            Dump4(Files Size<<16 ! Debug Fileinfo)                {001}
            %if Debug Options&4 = 0 %start
               F == Debug Files
               %while F ## NIL %cycle
                  Dump File(F)
                  F == F_Link
               %repeat
            %finish
            Dump4(0)                   {terminating length}       {001}
         %end                                                     {001}

         Select Debug Area                                        {001}
         Dump Section                                             {001}
         %if Debug Options&2 = 0 %start
            Dump Formats(Fglobals)
            Dump Variables(Dglobals)
         %finish
         Dump Procedures(P)                                       {001}
         Dump FileInfo                                            {001}
         Select Code Area                                         {001}
      %end                                                        {001}

      Bp = Bp+1;  Head == Blocks(Bp)
      Display   = Head_Display
      Wanted    = Head_Flags&Used
      Line Basis = Head_Line Base
      Diag Basis = Head_Diag Base
      Code Basis = Head_Code Base
      Line Info_Pending   = 0
      Line Info_Line      = Current Line
      Line Info_Last Line = Current Line
      Line Info_     Ca   = Code Basis
      Line Info_Last Ca   = Code Basis

      Bflags = 0
      Bflags = Bflags ! 16_80 %if Head == Block List %and Options&LL Trace # 0
      Bflags = Bflags ! 16_20 %if Head == Main Head
      Bflags = Bflags ! 16_10 %if Head_Attr&Attr Prim # 0
      Bflags = Bflags ! 16_04 %if Head_Attr&Attr Both # 0
      Bflags = Bflags ! 16_02 %if Head_Attr&Attr Xdef # 0
      Bflags = Bflags ! 16_01 %if Head_Event Mask # 0

      DebugA = 0                                                     {001}
      Select Code Area
      %if Wanted # 0 %start

         %if DEBUG # 0 %start                                        {001}
            Debug New Fragment(Ca, Current Line) %if InPrim = 0
            DebugP == NEW(ProcedurefmType)                           {001}
            DebugA = Addr(DebugP)                                    {001}
            DebugP = 0                                               {001}
            DebugP_Proc == Head                                      {001}
         %finish                                                     {001}

         %if Options&LL Decode # 0 %start
             Select Output(Decode Out)
             Dump Encoded(-1)
             Dump Encoded(Head_Code Base)
             Dump Encoded(Head_Ca)
             N = Current Line; N = 0 %if Head_Attr&Attr Prim # 0
             Dump Encoded(N); Put String (Block Id)
             Select Output(Object Out)
         %finish

         Frame = -Head_Frame

         %if Head == Entry Head %start
            Relocate(-Min SB, Cseg, Dsym, SymbolReloc)
            Dump4(16_E51F9000 + 8 +4)             {LDR _ Sb, [.-12]}
            ->OK
         %finish

         %if Head_Link == NIL %start
            N = 0
         %else
            N = (Head_Link_Code Base-Ca)>>2
            CSR("code block too large") %if N>>16 #0
         %finish
         Dump2(N&16_FFFF);  Dump(Bflags);  Dump((Display>>2)&255)
         %if Bflags&1 # 0 %start
            Dump4(Head_Event Mask)
            Dump4(Items(Head_Event  Body)_Ca-Head_Code Base)
            Dump4(Items(Head_Event Label)_Ca-Head_Code Base)
         %finish

         %if Head_Attr&Attr Xdef # 0 %and Head_Attr&Attr Needs Gp # 0 %start
            At = Ca
            Relocate(-Min SB, Cseg, Dsym, SymbolReloc)
         %finish

         %if Options&LL Vars # 0 %start
            Select Diag Area
            Dump2(Current Line&16_FFFF)
            Dump2(Head_Diag Size)
            Dump(Length(Block Id))
            Dump(Charno(Block Id, N)) %for N = 1, 1, Length(Block Id)
            Select Code Area
         %finish

         %if Head_Flags&No Entry = 0 %start
            Warn("Misplaced block ".ItoS(Head_Ca,0).ItoS(Ca, 1)) %if Head_Ca # Ca

            %if Head_Attr&Attr Xdef # 0 %and Head_Attr&Attr Needs Gp # 0 %start
               %if Head_Attr&Attr Both # 0 %start
                  Dump4(16_E51F7000 + 8 + Ca - At)     {LDR_R7, [.-12]}
               %finish
            %finish

            {can be squeezed if no locals & no parameters}
            %if Head_Attr&Attr Both # 0 %start      {simple display updating}
               %if Head_Attr&Attr Xdef # 0 %start
                  Dump4(16_E5175000 - Display) {LDR _ R5, D(R7)}
               %else
                  Dump4(16_E5195000 - Display) {LDR _ R5, D(Sb)}
               %finish
            %finish
            Warn("parameter overflow") %if Head_Pframe>>10 # 0
            Dump4(16_E1A0B00C)                {MOV _ R11, R12}
            %if Head_Pframe # 0 %start
               N = 16_E52C0004                {STR _ R0, [Sp, #-4]!}
               %if Head_Pframe > 4 %start
                  N = 16_E92C0003             {STM _ Sp!, <R0,R1>}
                  %if Head_Pframe > 8 %start
                     N = N ! 2_0100           {STM _ Sp!, <R0,R1,R2>}
                     %if Head_Pframe > 12 %start
                        N = N ! 2_1000        {STM _ Sp!, <R0,R1,R2,R3>}
                     %finish
                  %finish
               %finish
               Dump4(N)
            %finish

            Dump4(16_E92CCE20)           {STMDB _ Sp!, <R5,Sb,Fp,Ip,R14,Pc>}
            Dump4(16_E28CAF05)           {ADD _ Fp, Sp, #20} {onto PC}

            %if Head_Attr&Attr Xdef # 0 %and Head_Attr&Attr Needs Gp # 0 %start
               %if Head_Attr&Attr Both = 0 %start
                  Dump4(16_E51F9000 + 8 + Ca - At) {LDR _ Sb, [.-12]}
               %else
                  Dump4(16_E1A09007)               {MOV _ Sb, R7}
               %finish
            %finish

            %if Head_Attr&Attr Both # 0 %start    {simple display updating}
               Dump4(16_E509A000 - Display)       {STR _ Fp, D(Sb)}
            %finish

            {Now allocate the stack frame}
            %constintegerarray ULDR(1:4) = 16_E4994000, {LDR   _ 4, [SB]}
                                           16_E8990030, {LDMIA _ Sb, <4,5>}
                                           16_E8990070, {LDMIA _ Sb, <4,5,6>}
                                           16_E89900F0  {LDMIA _ Sb, <4,5,6,7>}
            %constintegerarray USTR(1:3) = 16_E52C4004, {STR   _ 4, [SP, #-4]!}
                                           16_E92C0030, {STMDB _ SP!, <4,5>}
                                           16_E92C0070  {STMDB _ SP!, <4,5,6>}

            %constinteger STM4           = 16_E92C00F0  {STMDB _ SP!, <4,5,6,7>}

            %if Frame # 0 %start
               %if Options&LL Assigned # 0 %start
                  N = Frame>>2;  M = N&3
                  %if N <= 3 %then M = N %else M = 4
                  Dump4(ULDR(M))
                  M = N&3
                  %if M # 0 %start
                     Dump4(USTR(M))
                     N = N-M
                  %finish
                  %if N # 0 %start
                     N = N>>2
                     %if N <= 5 %start
                        %cycle
                           Dump4(STM4)
                           N = N-1
                        %repeat %until N = 0
                     %else
                        Op = 16_E3A0 8000       {MOV _ 8, #0}
                        M = 16
                        %cycle
                           M = M-1 %and N = N>>2 %while N&3 = 0
                           Dump4(Op ! (M&15)<<8 ! N&255) {MOV _ 8, #n}
                           Op = 16_E388 8000    {ORR _ 8, 8, #0}
                           M = M-4      {another 8 bits worth}
                           N = N>>8
                        %repeat %until N = 0
                        Dump4(STM4)
                        Dump4(16_E2588001)
                        Dump4(16_CAFF FFFC)
                     %finish
                  %finish
               %else
                  N = Frame
                  M = 16
                  %while N # 0 %cycle
                     M = M-1 %and N = N>>2 %while N&3 = 0
                     Dump4(16_E24CC000 ! (M&15)<<8 ! N&255) {SUB _ Sp, #n}
                     M = M-4      {another 8 bits worth}
                     N = N>>8
                  %repeat
               %finish
            %finish
         %finish
      %finish

OK:   %cycle
         Readsymbol(Code)
         %unless 1 <= Code <= Max Dir %start
D(*):       CSR("Corrupt p2 directive".ItoS(Code, 1))
         %finish
         Show Code(Code) %if Options&LL Mon # 0
         ->D(Code)

{******** Debugger Support ********}
D(Dir DEBUG Start Proc):   D1 = Encoded Value     {Type}          {001}
                           D2 = Encoded Value     {Sourcepos}     {001}
                           %if DebugP ## NIL %start               {001}
                              DebugP_Type      = D1               {001}
                              DebugP_StartPos  = D2               {001}
                              DebugP_Args      = 0
                              DebugP_Name == Heap String(BlockId) {001}
                              DebugP_StartFile == DebugF
                           %finish                                {001}
                           %continue                              {001}
                                                                  {001}
D(Dir DEBUG End Proc):     D2 = Encoded Value     {Sourcepos}     {001}
                           %if DebugP ## NIL %start               {001}
                              DebugP_EndPos  = D2                 {001}
                              DebugP_EndFile == DebugF
                           %finish                                {001}
                           %continue                              {001}
{**********************************}

D(Dir Start Block): N = Encoded Value
                    Get String(Block Id, 127)                     {002}

                    %if Debug # 0 %and Wanted # 0 %and InPrim = 0 %start
                       Debug Terminate Fragment(Ca, Current Line-1)
                       Dump Block(Level+1, 0, InPrim, D1)         {001}
                       Debug New Fragment(Code Basis, Current Line)
                    %else
                       Dump Block(Level+1, 0, InPrim, D1)         {001}
                    %finish

                    %if DEBUG # 0 %and D1 # 0 %start              {001}
                       {Add D1 to the proc list at this level}    {001}
                       Debug List_Next == Record(D1)              {001}
                       Debug List == Record(D1)                   {001}
                    %finish                                       {001}

                    %if Options&LL Decode # 0 %start
                        Select Output (Decode Out)
                        Dump Encoded(-2); Dump Encoded(Previous Ca)
                        Dump Encoded(Code Basis)
                        Select Output (Object Out)
                    %finish
                    Select Code Area
                    %continue

D(Dir Diag):        Dump Diag Entry
                    %continue

                    %integerfn Type Map(%integer Prt, Fm, Ptype)
                       %switch T(0:15)
                       ->T(Prt)
                   
T( 0):                 %result = 0
T( 1): {integer}       %result = Type Signed Word        <<8 + 0
T( 2): {short}         %result = Type Signed Half        <<8 + 0
T( 3): {byte}          %result = Type Unsigned Byte      <<8 + 0
T( 4): {real}          %result = Type Float              <<8 + 0
T( 5): {longreal}      %result = Type Double             <<8 + 0
T( 6): {string}        %result = Type Unsigned Byte      <<8 + 0
T( 7): {record}        %result = (-Fm)                   <<8 + 0
T( 8): {boolean}       %result = Type Unsigned Byte      <<8 + 0
T( 9): {char}          %result = Type Unsigned Byte      <<8 + 0
T(10): {byte-enum}     %result = Type Unsigned Byte      <<8 + 0
T(11): {word-enum}     %result = Type Unsigned Half      <<8 + 0
T(12): {pointer}       %result = Type Map(Ptype, Fm, 0)  <<8 + 1
T(13): {set}           %result = 0
T(14): {unknown}       %result = 0
T(15):                 %result = Type Map(Ptype, Fm, Ptype) + 1
                    %end

                    %routine Append Diag(%record(DvarFm)%name D)
                       %if Dfm ## NIL %start      {to records}
                          %if Dfm_F_Vars == NIL %start
                             D_Link == D
                          %else
                             D_Link == Dfm_F_Vars_Link
                             Dfm_F_Vars_Link == D
                          %finish
                          Dfm_F_Vars == D
                       %else %if DebugP == NIL    {to globals}
                          %if Dglobals == NIL %start
                             D_Link == D
                          %else
                             D_Link == Dglobals_Link
                             Dglobals_Link == D
                          %finish
                          Dglobals == D
                       %else                     {to locals}
                          %if DebugP_Vars == NIL %start
                             D_Link == D
                          %else
                             D_Link == DebugP_Vars_Link
                             DebugP_Vars_Link == D
                          %finish
                          DebugP_Vars == D
                       %finish
                    %end

D(Dir DEBUG Var):   %begin
                       %record(DvarFm)%name D
                       %integer N, Prt, Ind, Base, Btype, Ptype, Disp, Fm, Type
                       %integer Offset, Size
                       %string(255) Id

                       Get String(Id, 255)
                       Prt         = Encoded Value {Primary type}
                       Ind         = Encoded Value {Indirect bit}
                       N           = Encoded Value {Class: 1=Local, 2=Static}
                       %if N = 1 %start
                          N = 3              {Automatic}
                       %else %if N = 2
                          N = 2              {Static}
                       %else
                          N = 0              {Unknown}
                       %finish
                       Btype       = Encoded Value {BaseType}
                       Ptype       = Encoded Value {PointerType}
                       Offset      = Encoded Value {Displacement}
                       Fm          = Encoded Value {Format}
                       Size        = Encoded Value {Size}
                       %return %if Prt = 0   {Enumerated definition?}

                       D == NEW(DvarFmType);  D = 0
                       D_Ident    == Heap String(Id)
                       D_Class     = N
                       D_Size      = Size
                       D_Offset    = Offset
                       D_SourcePos = Current Line
                       D_Type      = Type Map(Prt, Fm, Ptype)
                       D_Type      = D_Type+1 %if Ind # 0
                       Append Diag(D)
                    %end
                    %continue

D(Dir DEBUG Array): %begin
                       %integer Type, Fm
                       %record(DvarFm)%name D
                       %record(ArrayFm)%name A
                       %string(255) S
                       D == NEW(DvarFmType)
                       D = 0
                       Get String(S, 255)
                       D_Ident == Heap String(S)
                       D_Class = -1  {array marker}
                       A == NEW(ArrayFmType)
                       D_Array == A
                       A_Lower  = Encoded Value {Lower bound}
                       A_Upper  = Encoded Value {Upper Bound}
                       A_Total  = Encoded Value {Total Size}
                       Type     = Encoded Value {Type}
                       Fm       = Encoded Value {Format}
                       A_Type   = Type Map(Type, Fm, 0)
                       Append Diag(D)
                    %end
                    %continue

D(Dir Record On):   Record Diags = Encoded Value
                    Record Basis = Formpt(Record Diags) + Area Base_Record
                    %if DEBUG # 0 %start
                       Dfm == DebugFm(Record Diags)
                       Dfm_F == NEW(DFormatFmType)
                       Dfm_F_Vars == NIL
                       %if DebugP == NIL %start  {global}
                          %if Fglobals == NIL %start
                             Dfm_F_Link == Dfm_F
                          %else
                             Dfm_F_Link == Fglobals_Link
                             Fglobals_Link == Dfm_F
                          %finish
                          Fglobals == Dfm_F
                       %else
                          %if DebugP_Formats == NIL %start
                             Dfm_F_Link == Dfm_F
                          %else
                             Dfm_F_Link == DebugP_Formats_Link
                             DebugP_Formats_Link == Dfm_F
                          %finish
                          DebugP_Formats == Dfm_F
                       %finish
                    %finish
                    %continue

D(Dir Record Off):  %if Dumping Diags("") %start ;%finish
                    Select Code Area
                    Record Diags = 0
                    %if DEBUG # 0 %start
                       Dfm == NIL
                    %finish
                    %continue

D(Dir Slabel):
D(Dir Label):       N = Encoded Value+Reloc
                    Item == Items(N)
                    %continue %if Wanted = 0 %or Item_Flags&Deleted # 0
                    Set CC = 0 %if Item == CC Label
                    %if Item_Flags&Duplicated # 0 %start
                       Item_Flags = Item_Flags-Duplicated
                       %continue
                    %finish
                    %unless Item_Ca = Ca %start
                       Select Output(Report)
                       Printstring("Label error at line")
                       Write(Current Line, 1)
                       Printstring(" -- label actually at")
                       Write(Ca, 5)
                       Printstring(" but expected at")
                       Write(Item_Ca, 5)
                       Newline
                       %monitor %if Options&LL Mon # 0
                       Select Output(Object Out)
                    %finish
D(Dir Mark User):   %continue

D(Dir Const Addr):  N = Encoded Value
                    N = Encoded Value
                    Item == Next Item(Caddr Type)
                    %continue %if Wanted = 0
                    C = Item_Cond
                    At = (Ca+8) - (Item_Value+Area Base_Constant)
                    %if At&3 # 0 %start
                       %if Item_Flags&VeryLong # 0 %start
                          Dump4(16_E24F 0800 ! C<<12         ! At>>16)
                          Dump4(16_E240 0C00 ! C<<12 ! C<<16 ! At>>08&255)
                          Dump4(16_E240 0000 ! C<<12 ! C<<16 ! At&255)
                       %else %if Item_Flags&Long # 0
                          Dump4(16_E24F 0C00 ! C<<12 !         At>>8)
                          Dump4(16_E240 0000 ! C<<12 ! C<<16 ! At&255)
                       %else
                          CSR("bad Caddr") %unless 0 <= At <= 255
                          Dump4(16_E24F 0000 ! C<<12         ! At)
                       %finish
                    %else
                       At = At>>2
                       %if Item_Flags&VeryLong # 0 %start
                          Dump4(16_E24F 0700 ! C<<12         ! At>>16)
                          Dump4(16_E240 0B00 ! C<<12 ! C<<16 ! At>>08&255)
                          Dump4(16_E240 0F00 ! C<<12 ! C<<16 ! At&255)
                       %else %if Item_Flags&Long # 0
                          Dump4(16_E24F 0B00 ! C<<12         ! At>>8)
                          Dump4(16_E240 0F00 ! C<<12 ! C<<16 ! At&255)
                       %else
                          CSR("bad Caddr") %unless 0 <= At <= 255
                          Dump4(16_E24F 0F00 ! C<<12         ! At)
                       %finish
                    %finish
                    %continue

D(Dir Const Load):  N = Encoded Value
                    N = Encoded Value
                    Item == Next Item(Cload Type)
                    %continue %if Wanted = 0
                    C = Item_Cond
                    At = (Ca+8)-(Item_Value+Area Base_Constant)   {-ve disp}
                    {At = {X<<20 ! Y<<12 ! Z}
                    %if Item_Flags&VeryLong # 0 %start
                       {SUB _ R14, Pc, Z<<20}
                       {SUB _ R14, R14, Y<<12}
                       {LDR _ R?, [R14, Z]}
                       Dump4(16_E24F 0600 ! C<<12         ! At>>20)
                       Dump4(16_E240 0A00 ! C<<12 ! C<<16 ! At>>12&255)
                       Dump4(16_E510 0000 ! C<<12 ! C<<16 ! At&16_FFF)
                    %else %if Item_Flags&Long # 0
                       CSR("bad long cload") %unless At>>(12+8) = 0
                       {SUB _ R14, Pc, Y<<12}
                       {LDR _ R?, [R14, Z]}
                       Dump4(16_E24F 0A00 ! C<<12         ! At>>12)
                       Dump4(16_E510 0000 ! C<<12 ! C<<16 ! At&16_FFF)
                    %else
                       CSR("Bad Cload") %unless 0 <= At <= 16_0FFF
                       Dump4(16_E51F 0000 ! C<<12         ! At&16_FFF)
                    %finish
                    %continue

D(Dir Real Load):   N = Encoded Value
                    N = Encoded Value
                    N = Encoded Value<<15      {type flag: 0=short, 1=long}
                    Item == Next Item(Rload Type)
                    %continue %if Wanted = 0
                    At = ((Ca+8)-(Area Base_Constant+Item_Value))>>2 {-ve disp}
                    {Disp = At<<2 = X<<18 ! Y<<10 ! Z<<2}
                    %if Item_Flags&VeryLong # 0 %start
                       {SUB _ R14, Pc, X<<18}
                       {SUB _ R14, R14, Y<<10}
                       {LDF _ R?, [R14, Z]}
                       Dump4(16_E24F E700 ! At>>16)
                       Dump4(16_E24E EB00 ! At>>8&255)
                       Dump4(16_ED1E 0100 ! Item_Cond<<12 ! At&16_FF ! N)
                    %else %if Item_Flags&Long # 0
                       CSR("bad long cload") %unless At>>16 = 0
                       {SUB _ R14, Pc, Y<<12}
                       {LDF _ R?, [R14, Z]}
                       Dump4(16_E24F EB00 ! At>>8)
                       Dump4(16_ED1E 0100 ! Item_Cond<<12 ! At&16_FF ! N)
                    %else
                       CSR("Bad Cload") %unless 0 <= At <= 16_0FF
                       Dump4(16_ED1F 0100 ! At ! Item_Cond<<12 ! N)
                    %finish
                    %continue

D(Dir Spec Load):   N = Encoded Value
                    N = Encoded Value
                    Item == Next Item(Sload Type)
                    %continue %if Wanted = 0
                    X == External(Item_Value)
                    N = 16_E599 0000 ! Item_Cond<<12
                    At = X_Disp
                    N = N !! 16_0080 0000 %and At = -At %if At < 0
                    CSR("external out of reach") %unless N < 4096
                    Dump4(N ! At)
                    %continue

D(Dir Branch):      N = Encoded Value
                    N = Encoded Value
                    Item == Next Item(Branch Type)
                    %continue %if Item_Flags = Deleted %or Wanted = 0
                    CSR("label deleted") %if Item_Label_Flags&Deleted # 0
                    %if Item_Flags&Absorbed # 0 %start
                       Set CC = (Branch(Item_Cond)&16_F0) !! 16_E0
                       CC Label == Item_Label
                    %else
                       At = Item_Label_Ca
                       CSR("Jump to missing switch label") %if At < 0
                       Dump Branch(Branch(Item_Cond), At)
                    %finish
                    %continue

D(Dir McLabel):

     M = Encoded Value+Reloc     {the label}
     N = Encoded Value           {the instruction}
     %continue %if Wanted = 0
     M = Items(M)_Ca             {address of label}
     Dump4(N ! ((M-Ca-8)>>2)&16_00FF FFFF)
     %continue

D(Dir Line):

     Current Line = Encoded Value
     Update Line %if Wanted # 0 %and Head_Attr&Attr Prim = 0
     %if Options&LL Decode # 0 %start
         Select Output(Decode Out)
         Dump Encoded(Current Line); Dump Encoded(Ca)
         Select Output(Object Out)
     %finish
     %continue

D(Dir Include):

     Get String(Swork, 127);  Update Include(Swork)
     %continue

D(Dir Return):   {*** return from block ***}

      Item == Next Item(Return Type)
      N = Encoded Value
      %continue %if Wanted = 0
      %if Debug # 0 %and DebugP ## NIL %start
         %begin
            %record(PreturnFm)%name P == NEW(PreturnFmType)
            P_Ca = Ca
            P_Link == DebugP_Return
            DebugP_Return == P
            DebugP_Nreturns = DebugP_Nreturns+1
         %end
      %finish
      %if Head_Attr&Attr Both # 0 %start
         Dump4(16_E51A5014)                   {LDR _ R5, -20(Fp)}
         Dump4(16_E5095000 - Display)         {STR _ R5, D(Sb)}
      %finish
      Dump4(16_E95A9600)                   {LDMDB _ Sb, Fp, Sp, Pc^}
      %continue

D(Dir Ext):  {*** external object definition ***}

      Readsymbol(N)
      Skip Bytes(N+1)
      N = Encoded Value
      %continue

D(Dir Call):      N = Encoded Value
                  Item == Next Item(Call Type)
                  %continue %if Wanted = 0
                  Dump Branch(16_EB, Item_Label_Ca)
                  %continue

D(Dir Xref):      N = Encoded Value+Xreloc       {external reference}
                  M = Encoded Value              {register}
                  %continue %if Wanted = 0
                  X == External(N)
                  N = X_Disp;  N = 16_0080 0000 - N %if N < 0
                  Dump4(16_E5990000 !! N ! M<<12)
                  %continue

D(Dir xCall):     N = Encoded Value
                  Item == Next Item(External Type)
                  %continue %if Wanted = 0
                  X == External(Item_Value)
                  Relocate(16_EB000000, CSeg, External Index(X), PcReloc)
                  %continue

D(Dir Assigned):  Next Prim(16_0B);  %continue
D(Dir Prim):      N = Encoded Value
                  %if N = Enter Prim %then Op = 16_AB %else Op = 16_EB
                  Next Prim(Op);  %continue

D(Dir Area):      M = Encoded Value            {area}
                  N = Encoded Value            {offset}
                  %if M = 0 %start             {code area}
                     Select Code Area
                  %else %if M = 1              {global area}
                     Select Global Area(N)
                  %else %if M = 2              {constant area}
                     Select Pure Area(Area Base_Constant + N)
                  %else %if M = 3              {global array area}
                     Select Global Area(Area Base_Global Array + N + Min SB)
                  %else
                     CSR("Area/1")
                  %finish
                  %continue

D(Dir Swdef):     Lb = Encoded Value+Reloc
                  Ub = Encoded Value+Reloc
                  %for N = Lb, 1, Ub %cycle
                     At = Items(N)_Ca
                     %if At < 0 %start               {missing}
                        M = Prim Map(Sw Jump)
                        At = Items(M)_Ca+Sw Error %if M # 0
                     %finish
                     Relocate(At, CSeg, CSym, SymbolReloc)
                  %repeat
                  %continue

D(Dir Sw Ref):    N = Encoded Value
                  %continue %if Wanted = 0
                  Relocate(Area Base_Constant+N, CSeg, CSym, SymbolReloc)
                  %continue

D(Dir Modify):    N = Encoded Value                         {address}
                  M = Encoded Value                         {increment}
                  N = Current Address-N
                  Byte(N+3) = Byte(N+3) & (\1)              {->post indexed}
                  Byte(N+2) = Byte(N+2) & 127 %and M = -M %if M < 0
                  Byte(N+1) = Byte(N+1) ! (M>>8)&15
                  Byte(N+0) = M&255
                  CSR("bad modification") %if M>>16 # 0
                  %continue

D(Dir Header):    N = Encoded Value                         {area code}
                  M = Encoded Value                         {zero'th addr}
                  %if N = 1 %start                          {own area}
                     Relocate(M-Min SB, DSeg, DSym, SymbolReloc){add in own base}
                  %else %if N = 2                           {constant area}
                     Relocate(M+Area Base_Constant, DSeg, CSym, SymbolReloc) {add in code base}
                  %else %if N = 3                           {own array area}
                     Relocate(M+Area Base_Global Array, DSeg, DSym, SymbolReloc){add in own base}
                  %else
                     CSR("Bad header area")
                  %finish
                  Relocate(Encoded Value+Area Base_Constant, DSeg, CSym, SymbolReloc) {relocate DV}
                  %continue

D(Dir Init):      N = Encoded Value                         {area flag}
                  Work = Encoded Value                      {disp}
                  %if N = 0 %start                          {SB relative}
                     Relocate(N-Min SB, DSeg, DSym, SymbolReloc)
                  %else %if N = -1                          {constant area}
                     Relocate(Work+Area Base_Constant, DSeg, CSym, SymbolReloc)
                  %else                                     {external}
                     CSR("INIT")
                  %finish
                  %continue

D(Dir Thunk):     N = Encoded Value+Reloc            {procedure to call}
                  M = Encoded Value                  {static slot}
                  Item == Next Item(Thunk Type)
                  %continue %if Wanted = 0
                  Select Global Area(M)
                  Relocate(Item_Label_Ca, Dseg, Csym, SymbolReloc)
                  Select Code Area
                  %continue

D(Dir xThunk):    N = Encoded Value+Xreloc
                  M = Encoded Value
                  %continue %if Wanted = 0
                  Select Global Area(M)
                  Relocate(0, Dseg, External Index(External(N)), SymbolReloc)
                  Select Code Area
                  %continue

D(Dir Dump):      N = Encoded Value
                  %if Ca == Code Basis %start
                     %if Wanted = 0 %start
                        Skip Bytes(N)
                     %else
                        %cycle
                           N = N-1
                           Readsymbol(xxx)
                           %if Set CC # 0 %and N&3 = 0 %start
                              CSR("bad CC to change") %if xxx>>4 # 14
                              xxx = xxx !! Set CC
                           %finish
                           Dump(xxx)
                        %repeat %until N <= 0
                     %finish
                  %else
                     %cycle
                        Readsymbol(xxx);  Dump(xxx)
                        N = N-1
                     %repeat %until N <= 0
                  %finish
      %repeat

D(Dir End Block):   N = Encoded Value   { 1}
                    N = Encoded Value   { 2}
                    N = Encoded Value   { 3}
                    N = Encoded Value   { 4}
                    N = Encoded Value   { 5}
                    N = Encoded Value   { 6}
                    N = Encoded Value   { 7}
                    N = Encoded Value   { 8}
                    N = Encoded Value   { 9}
                    N = Encoded Value   {10}
                    N = Encoded Value   {11}
                    N = Encoded Value   {12}

      %if Debug # 0 %start                                        {001}
         %if Wanted # 0 %and InPrim = 0 %start
            Debug Terminate Fragment(Code Basis, Current Line)
         %finish
         Debug List_Next == NIL                                   {001}
         %if DebugP ## NIL %start                                 {001}
            DebugP_Inner == Debug Base_Next                       {001}
         %else                                                    {001}
            DebugA = Addr(Debug Base_Next)                        {001}
         %finish                                                  {001}
      %finish                                                     {001}

      Previous Ca = Ca
      %if Wanted # 0 %and Level >= 0 %start
         %if Head_Attr&Attr Prim = 0 %start
            Current Line = Current Line+1
            %if Dumping Diags("") %start ;%finish
         %finish
      %finish

      %return %if Finish >= 0

      %if Debug # 0 %start                                        {001}
         DebugP == Record(Total Debug List)                       {001}
         Allocate Debug Information(DebugP)                       {001}
         Allocate Buffer(Bseg, Bugs Size)                         {001}
         Dump Debug Information(DebugP)                           {001}
      %finish                                                     {001}

      {close off object file}

      %if Options&LL Decode # 0 %start
          Select Output(Decode Out)
          Dump Encoded(-5)
          Dump Encoded(Extra Base);  Dump Encoded(Xentry Base + Xentry)
          Select Output(Object Out)
      %finish
      %if Options&LL Assigned # 0 %start   {4-words to speed up unassigning}
         Select Global Area(0)
         Dump2(16_8080);  Dump2(16_8080)
         Dump2(16_8080);  Dump2(16_8080)
         Dump2(16_8080);  Dump2(16_8080)
         Dump2(16_8080);  Dump2(16_8080)
      %finish

      %begin     {fill in external data links and add external definitions}
         %record(Usefm)%name U
         %record(Xfm)%name   X
         %integer N
         U == Total Uses
         %while U ## NIL %cycle
            X == U_X;  U == U_Link
            %continue %if X == NIL %or X_Flags&Ext Prim # 0
            N = External Index(X)
            %if X_Flags&Ext Defn = 0 %start             {external reference}
               %if X_Flags&Ext Code = 0 %start          {data reference}
                  Select Global Area(X_Disp)            {SB relative}
                  Relocate(0, DSeg, N, SymbolReloc)     {S-area relative}
               %finish
            %finish
         %repeat
      %end

      %begin     {fill in BLOCK area}
         %integer J, N
         %string(255) M

         %routine Dump Block Diag Pointer(%record(Blockfm)%name B)
            {NOTE: these are dumped in reverse order}
            %if B ## NIL %start
               Dump Block Diag Pointer(B_Link)
               Relocate(B_Diag Base, CSeg, CSym, SymbolReloc)
            %finish
         %end

         Select Pure Area(Area Base_Block)
         %if Options&LL Trace # 0 %start
            Dump(Interface_Language)
            M = Interface_Module
            N = Length(M)
            Dump(N);  Dump(Charno(M, J)) %for J = 1, 1, N
            N = N+1
            %cycle
               N = N+1
               %exit %if N&3 = 0
               Dump(0)
            %repeat
            Dump Block Diag Pointer(Block List)
            %if Options&LL Records = 0 %start
               Dump4(0)
            %else
               Relocate(Area Base_Record, CSeg, CSym, SymbolReloc)
            %finish
            Relocate(Area Base_Block, CSeg, CSym, SymbolReloc)
         %finish
         Dump4(16_F82F0000)                    {Magic marker}
      %end

      %if Main Program # 0 %start              {pull in the main entry point}
          Select Pure Area(0)
          %if Debug = 0 %start
             Relocate(16_EA000000, CSeg, BSym, Pc Reloc) {B _ startup}
          %else
             Relocate(16_EA000000, CSeg, ESym, Pc Reloc) {B _ startup}
          %finish
          Entry Reference = 1
      %finish

      Rel1 No = Segment Reloc(CSeg)_Entries
      Rel2 No = Segment Reloc(DSeg)_Entries
      Rel3 No = Segment Reloc(Bseg)_Entries

      Dump Header
      Dump Strings
      Dump Symbols
      Dump Segment(CSeg);  Dump Relocation(CSeg)
      Dump Segment(DSeg);  Dump Relocation(DSeg)
      %return %if Debug = 0
      Dump Segment(BSeg);  Dump Relocation(BSeg)
   %end

   %integer Z
   %if Interface_Language = 0 %start
      Main Entry Id = "3L_imp___entry_point"
   %else %if Interface_Language = 1
      Main Entry Id = "3L_pascal___entry_point"
   %else
      Main Entry Id = "3L_?___entry_point"
   %finish

   Debug Base = 0                                                 {001}

   Select Output(Report)
   Bp = -1

   Reloc  = 0
   Xreloc = 0
   Ip     = Interface_Def Count
   Select Input(Directives In)
   Input Block(0, -1)
   Interface_Block Count = Bp                 {correct the guess}
        Ep = Encoded Value
         Z = Encoded Value
   Min SB  = Encoded Value

      Max SB   = (Interface_Global Size + Interface_Prim Global Size+3)&(\3)
      Area Size_Global Array  = (Interface_Global Array Size+3)&(\3)
      Area Size_Constant  = (Interface_Constant Size    -
                                + Interface_Prim Constant Size + 3)&(\3)
      Reloc  = Interface_Def Count + Interface_Ref Count+1
      Xreloc = Interface_External Count
      Ip     = Reloc + Interface_Prim Def Count
      Select Input(PrimDir In)
      Input Block(Ip, -1)


   Define Prim Map
   Mark Unused Blocks
   Process Blocks
   Allocate Blocks
   Mark Forward

   Stretch Blocks

   Allocate Buffer(CSeg, Code Size)
   Allocate Buffer(DSeg, Data Size)

   Segment Reloc(Cseg) = 0; Segment Reloc(Cseg)_Base = 0                   {001}
   Segment Reloc(Dseg) = 0; Segment Reloc(Dseg)_Base = Code Size           {001}
   Segment Reloc(Bseg) = 0; Segment Reloc(Bseg)_Base = Code Size+Data Size {001}

   Select Output(Object Out)
   Bp = -1
   %if Options&LL Decode # 0 %start
       %begin
          %string(127) Compiler Id
          Compiler Id = "*Compiled by ". Product Code . ":"                     -
                                       . P1Version    . "-"                      -
                                       . P2Version    . "-"                      -
                                       . P3Version    . " "                    -
                                       . Date         . " "                    -
                                       . Time
          Select Output(Decode Out)
          Dump Encoded(-3); Put String (Compiler Id ); Dump Encoded(0)
          Dump Encoded(0);Dump Encoded(0)
          Put String (Interface_Source File)
          Select Output(Object Out)
       %end
   %finish

   Z = Symbol Entry(CodeArea, 1, 0, CodeArea)                      {$CODEAREA}
   Z = Symbol Entry(DataArea, 1, 0, DataArea)                      {$DATAAREA}
   %if Debug # 0 %start
      Z = Symbol Entry(DbugArea, 1, 0, DbugArea)                   {$BUGSAREA}
      Z = Symbol Entry(FreeArea, 2, 0, DataArea) %if Main Program # 0 {?___ENTRY_POINT}
   %else
      Z = Symbol Entry(DbugArea, 2, 0, DataArea) %if Main Program # 0 {?___ENTRY_POINT}
   %finish

   Reloc = 0;  Xreloc = 0
   Ip = Interface_Def Count
   Select Input(Directives In);  Reset Input
   Debug Include(Interface_Source File, 0, 0)
   Dump Block(-1, 1, 0, Total Debug List)
      Reloc = Interface_Def Count + Interface_Ref Count+1
     Xreloc = Interface_External Count
      Ip = Reloc + Interface_Prim Def Count
      Select Input(PrimDir In);  Reset Input
      Z = Encoded Value    {skip ref count}
      Z = Encoded Value    {skip def count}
      Z = Encoded Value    {skip block count}
      Z = Encoded Value    {skip external count}
      Z = Encoded Value    {skip global size}
      Z = Encoded Value    {skip formats}
      Dump Block(-1, -1, 1, Z {dummy})                               {001}
      %if Options&LL Decode # 0 %start
         Select Output(Decode Out)
         Dump Encoded(-4)
         Select Output(Object Out)
      %finish
%end

%endoffile