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

                       {Pass 2 for ARM IMP}

%externalstring(7) P2 Version = "004"

! To Do:
!

!Revision history:
!
! 004   7-Sep-88 PSR Made DALLOC forget Sp and
!                    made FORGET forget locked regs {C-136}
! 003  22-Jun-88 PSR Changes to compile native on A310
!                    Made diag string 127 instead of 31
! 002  23-Feb-88 PSR Changed to ARM calling stack frame
! 001   4-FEB-88 PSR Started additions for ACORN DEBUG
!                  - Record diags dumped in reverse order (that of declaration)
! 0.9  15-Jan-88 PSR Removed the %name %array ILABELS by means of
!                    another recordformat.
!       ******* release 1.2 sent to Acorn & Validated *******
!       2-Nov-87 PSR Put FORGET DESTINATION in JUMP BACKWARDS to permit
!                    unassigned checking of control
!                    catching unassigned FOR control variables
!                  - Made MULTIPLY call LOAD PROTECTED in case destination
!                    register is already in use. (SCR/87/448)
!       9-Oct-87 PSR Made R14 preferable when hazarding to prevent
!                    corrupting a parameter (e.g. for REAL EXP). (SCR/87/449)
!                  - Added check for "Subroutines nested too deeply" (SCR/87/447)
! 0.8   5-Oct-87 PSR Removed optimisation for C1*(V1+C2) :: overflow!
!                  - Added check for the cases: (I<<n) + Real
!                                          and: Real + (I<<n) (SCR/87/407)
!                  - MULTIPLY was corrupting INVERTED as it used the COMPARE
!                    mechanism to generate the in-line code for *. This
!                    mis-compiled 0 >= A*B (SCR/87/409)
!                  - Fixed OPERATE which was converting A<<C - D into
!                    D - A<<C. It now uses RSB instead. (SCR/87/408)
!                  - Corrected a problem in FLOAT which made -10 into -2.0
!                    (SCR/87/411)
!                  - Added explicit check for setting bit out of range in
!                    BUILD SET. (SCR/87/423)
! 0.7  19-sep-87 PSR Corrected problem with hazard all after PASS PARAMETERS
!                    corrupting one (or more) of the parameter registers
!                    (SCR/87/392)
!                  - Set comparison changed to fix miscompilation of
!                    IF [] >= [something] which was returning a zero/non-zero
!                    condition code but testing for  a >= or <= code (SCR/87/398)
!                  - Added internally-generated NO-OP 128+'0' + <tag>
!                  - made WORK AREAS an indefinitely expanding list. (SCR/87/400)
!                  - Corrected bugs in ABS(ABS(X)), ABS(-X), and ABS(\X).
!                    (SCR/87/401, SCR/87/422)
! 0.6  16-Sep-87 PSR Test version for BSI visit
!                  - Made BUILD SET save & restore oper & link to fix
!                    problems with S := [1..x]-[y]; (SCR/87/388)
!                  - Set the WORK SET bit on the temp created by BUILD SET
!                  - Problem with passing longreals as parameters. The LDM
!                    in PPARAMS.INC was not preceded by the necessary HAZARDS
!                  - ABS(X) used unsafe MOVS to set condition code,
!                    would not work if CC already set incorrectly.
! 0.5   7-Aug-87 NPH [SCR/87/324] Set value to Default value in Update Line
!
! 0.5   4-Aug-87 NPH [SCR/87/325] If saved, Wsp must be saved after a Dalloc
!                    Quick soln : save it again if it has been saved.
!
!      30-Jul-87 PSR PESSIMISE got the wrong displacement when temps were
!                    a long way away from FP
!                    Was also a problem with STAB.
!       8-Jul-87 PSR Forget destination not forgetting after R_a(n) = ...
!                  - Stopped optimising X&255 -> byte load when checkable
! 0.4  24-Jun-87 PSR The event trap routine was forgetting everything
!                    AFTER it had planted the LDR Wsp .... This was wrong
!                    it the save area was too far away for a simple load.
!                    This gave rise to an address error in Pascal Pass1 after
!                    a *FATAL ERROR report.
! 0.3  14-Jun-87 PSR Fixed ALL CONST when first string isn't constant
!                  - Fixed PRINTSTRING("")
! 0.2  28-Mar-86 PSR Tightened up setting condition-code values
!                  - remembered ZERO after in-line loops
!                  - added optimisation to remember constants after IF x=const
!                  - improved handling of SHORTS (esp in S&16_FFFF)
!                  - optimised X op Y shift Const, X shift const op Y
!                  - corrected problem with OWNs living at 0(SB)
!                  - corrected problem causing Record=0 to clear by bytes.
! 0.01 24-Mar-86 PSR Released to Acorn
! 0.01 27-Jan-86 PSR Cloned from SUN pass2 v0.39

%owninteger   Diag         = 0,
              Debug        = 0,        {#0 if -DEBUG specified}   {001}
              Current Line = 0         {here to aid diagnostics}

%constinteger MonCode    = 1<<0,
              MonStack   = 1<<1,
              MonReg     = 1<<2,
              MonOperand = 1<<3,
              MonOperate = 1<<4,
              MonMove    = 1<<5,
              MonLine    = 1<<6,
              MonOpt     = 1<<7,
              MonCond    = 1<<8,
              MonBang    = 1<<9

%constinteger       Infinity =  (-1)>>1,
              Minus Infinity = \Infinity

%constinteger Max Vars        =   2000,  Var Top       = Max Vars>>6,
              Max Labels      =   8000,  Max Label     = Max Labels!255,
              Max Work Areas  =    500,  Max Work Area = Max Work Areas!15,
              Max Nesting     =     17,
              Max Bound       =      7,
              Set Size        = 256//8

{Types}

%constinteger Undefined = 0,
              Integers  = 1,
              Shorts    = 2,
              Halves    = 3,
              Bytes     = 4,
              Addrs     = 5,
              Reals     = 6,
              Lreals    = 7,
              Strings   = 8,
              Records   = 9,
              Generals  = 10,
              Labels    = 11,
              Booleans  = 12,
              Sets      = 13

%constbytearray Internal Type(Undefined:Sets) =
      Undefined, Integers, Shorts, Halves,   Bytes,  Addrs,
      Reals,     Lreals,
      Strings,   Records,  Generals, Labels, Bytes, Sets

%conststring(7)%array TypeId(Undefined:Sets) =
               "Unknown", "Integer", "Short  ", "Half   ", "Byte   ", "Addr   ",
               "Real   ", "Lreal  ",
               "String ", "Record ", "General", "Label  ", "Boolean", "Set    "

%constbytearray Type Fmt (Undefined:Sets) = 0,4,2,2,1,4,4,8,0,0,0, 0,1,32
%constbytearray Type Code(Undefined:Sets) = 0,1,6,6,5,1,2,8,3,4,0,10,0,0
%constbytearray Type Size(Undefined:Sets) = 0,4,2,2,1,4,4,8,0,0,12,0,2,Set Size
%constbytearray Ucheck   (Undefined:Sets) = 0,1,0,0,0,1,1,1,1,0,0,0,0,0

%from IMP %include Option3l, Stream3l, Spec3l, Interfac,
                      Comm23, Attr, Lflags
%include "inc.Opcodes"

%externalroutine PASS2(%record(Commfm)%name Interface)
   %constinteger Word Length    = 4,           {in bytes}
                 Alignment      = 3,           {word alignment needed}
                 Alignment Mask = \Alignment

   %externalroutinespec D68000(%integer Op, Ca)
   %externalroutinespec Dump Encoded(%integer N)
   %include "inc.XSPECS"

   {Register info}

   {Integer activities are: 0 = free
   {                       -1 = locked
   {                       >0 = claimed that many times
   {NOTE: registers are only claimed by LOAD (or the load implied by OPTIMISE}

              {  Register         Alias}
  %constinteger  None =  0,
                 R0   =  1,
                 R1   =  2,
                 R2   =  3,
                 R3   =  4,
                 R4   =  5,
                 R5   =  6,
                 R6   =  7,
                 R7   =  8,
                 R8   =  9,
                 R9   = 10,       Sb = R9,
                R10   = 11,       Fp = R10,
                R11   = 12,       Ip = R11,
                R12   = 13,       Sp = R12,
                R13   = 14,       Sl = R13,
                R14   = 15,     Link = R14,
                R15   = 16,       Pc = R15,
                Any   = 17,
                F0    = 18,
                F1    = 19,
                F2    = 20,
                F3    = 21,
                F4    = 22,
                F5    = 23,
                F6    = 24,
                F7    = 25,
                AnyF  = 26
              { Register          Alias}

   %constbytearray Actual(0:AnyF) = 0,  0,  1,   2,   3,  4,   5,   6,   7,
                                        8,  9,  10,  11, 12,  13,  14,  15, 0,
                                        0,  1,   2,   3,  4,   5,   6,   7, 0


   %conststring(3)%array RegId(0:AnyF) = "",
              "R0 ", "R1 ", "R2 ", "R3 ", "R4 ", "R5 ", "R6 ", "R7 ",
              "R8 ", "R9 ", "R10", "R11", "R12", "R13", "R14", "R15", "R? ",
              "F0 ", "F1 ", "F2 ", "F3 ", "F4 ", "F5 ", "F6 ", "F7 ", "F? "

   %constbytearray Rtype(0:AnyF) = Undefined, Integers(17), Lreals(9)

   %recordformat Boundfm(%integer Lower, Upper, Mult)
   %recordformat Afm(%integer Dimension,
                              Total Size,
                              Zero Displacement,
                              DV,
                              Local Frame,
                              Base,
       %record(Boundfm)%array Bound(1:Max Bound))

   %constrecord(Afm)%name A type == 0             {for NEW}

   %recordformat Varfm(%integer Flags,
                       %byte Base, Prim,
                    %byte  Type, Form,
                    (%longreal Rvar %or
                     %integer Disp, (%integer Extra %or %record(Afm)%name Adata)),
                    (%integer Format %or %integer Scale),
                    %integer Area)


   %recordformatspec Stackfm
   %recordformat Olfm(%integer  Oper, %record(Stackfm)%name Link)
   %recordformat  Xfm(%integer Xsize, %record(Stackfm)%name Index)

   %recordformat Datafm( -
           %record(Varfm)    V,
           %integer Varno,
           %record(Varfm)%name Fv,
           (%integer Bias %or %byte Reg, Label),
           %record(Stackfm)%name  Params, Record,
           (%integer Oper, %record(Stackfm)%name Link %or %record(Olfm) Oplink),
           (%integer Xsize, %record(Stackfm)%name Index %or %record(Xfm) X))

   %recordformat Memberfm(%integer Const, Items,
                          %record(Stackfm)%name A, B,
                          %record(Memberfm)%name Link)

   %constrecord(Memberfm)%name Memberfm Type == 0

   %recordformat Stackfm( -
      %record(Varfm)     V                   %or
      %record(Datafm)    Data                %or
      %integer Flags,
      %byte Base, Prim,
      %byte  Type, Form,
      (%longreal Rval %or %integer Rhigh, Rlow -
        %or (%integer Disp, (%integer Extra %or %record(Afm)%name Adata)),
      (%integer Format %or %integer Scale),
      %integer Area,
      %integer Varno,
      (%record(Varfm)%name Fv %or %record(Memberfm)%name Members),
      (%integer Bias %or %byte Reg, Label),
      %record(Stackfm)%name     Params, Record,
      (%integer  Oper, %record(Stackfm)%name Link  %or %record(Olfm) Oplink),
      (%integer Xsize, %record(Stackfm)%name Index %or %record(Xfm) X)),
      %record(Stackfm)%name          Using, Stack)

   %constrecord(Stackfm)%name Stackfm Type == 0

   %recordformat Withfm(%integer Key, %record(Datafm) Data,
                        %record(Withfm)%name Link)
   %constrecord(Withfm)%name Withfm Type == 0

   %recordformat Workfm(%integer Size, Displacement, Validity)
   %recordformat WorkVfm(%record(WorkVfm)%name Link,
                         %record(Workfm)%array W(0:30))
   %constrecord(WorkVfm)%name WorkVfmType == 0
   %record(WorkVfm) Work List = 0
   %integer Work Validity = 1, Last Work = -1

   {Flag bits}

   %constinteger  By Ref      = 1<< 0,            {in FLAGS}
                  Array       = 1<< 1,
                  Parameter   = 1<< 2,            {procedure parameter}
                  Defered     = 1<< 3,            {needs indirection}
                  Hazarded    = 1<< 4,
                  Static      = 1<< 5,
                  Arrayname   = 1<< 6,
                  Known Ass   = 1<< 7,            {cannot be unassigned}
                  Prim Proc   = 1<< 8,
                  Primitive   = 1<< 9,            {prim procedure}
                  Xproc Spec  = 1<<10,            {external procedure}
                  Closed      = 1<<11,            {cannot return}
                  Internal    = 1<<12,            {can use JSB}
                  Call it     = 1<<13,            {cannot use JSB}
                  Null Set    = 1<<14,
                  Keep Local  = 1<<15,
                  Nasty Proc  = 1<<16,            {uses the environment}
                  Awanted     = 1<<17,
                  Work Set    = 1<<18,
                  Answer      = 1<<19,
                  Checkable   = 1<<20,
                  Pred Call   = 1<<21,            {is a predicate}
                  Stored With = 1<<22,
                  Xdata Spec  = 1<<23,
                  Xproc Def   = 1<<24

   %recordformat Forfm(%byte             Label,  Entry, Reg, CC,
                       %integer Type,
                       %integer          AS,
                       %record(Datafm) Control, Final,
                       %record(Forfm)%name Link)
   %constrecord(Forfm)%name ForfmType == 0
   %ownrecord  (Forfm)%name Fors      == 0

   %ownrecord(Stackfm)%name   Stack == 0
   %ownrecord(Stackfm)%name   Using == 0,
                              Dasl  == 0

   %recordformat Valuefm(%longreal       Real       %or -
                         %integer        Integer    %or -
                         %string(255)    String     %or -
                         %bytearray      Fill(0:255))

   %ownrecord(Valuefm) Value         = 0,
                       Default Value = 0


{Internal operations}

   %constinteger  Real Shift = 21

   %constinteger  NOTx  =  1,                 {Integer operations}
                  NEGx  =  2,
                  ABSx  =  3,
                  ADDx  =  4,
                  SUBx  =  5,
                  MULx  =  6,
                  DIVx  =  7,
                  EXPx  =  8,
                  ANDx  =  9,
                   ORx  = 10,
                  XORx  = 11,
                  BICx  = 12,
                  ROTx  = 13,
                  LSHx  = 14,
                  RSHx  = 15,
                  REMx  = 16,
                  MODx  = 17,
                  MULHx = 18,                 {special for halfword multiply}
                  UDIVx = 19,                 {unsigned divide}
                  UREMx = 20,                 {unsigned rem}
                  EXTx  = 21,
                 CONCx  = 22,
                 RNEGx  = NEGx+Real Shift,    {floating-point operations}
                 RABSx  = ABSx+Real Shift,
                 RADDx  = ADDx+Real Shift,
                 RSUBx  = SUBx+Real Shift,
                 RMULx  = MULx+Real Shift,
                 RDIVx  = DIVx+Real Shift,
                 REXPx  = EXPx+Real Shift


   %conststring(4)%array OperId(NOTx:REXPx) =
                 "not ", "neg ", "abs ",
                 "add ", "sub ", "mul ", "div ", "exp ",
                 "and ", "or  ", "xor ", "bic ", "rot ", "lsh ", "rsh ",
                 "rem ", "mod ",
                 "ext ", "mulh", "udiv", "urem", "conc",
                 "negr", "absr",
                 "addr", "subr", "mulr", "divr", "expr"

{Oper flags}

   %constinteger Commutative = 1<<0,
                 InPrim      = 1<<1,
                 Easy        = 1<<2,
                 Selfop      = 1<<3,
                 Unary       = 1<<5,
                 Incdec      = 1<<6,
                 No Assoc    = 1<<7,
                 Weak Assoc  = 1<<8,   Assoc Mask = No Assoc!Weak Assoc,
                 Nullop      = 1<<9

   %constshortarray Oper Flags(NOTx:REXPx) =
                  {NOTx}  Unary!Selfop,
                  {NEGx}  Unary!Selfop,
                  {ABSx}  Unary,
                  {ADDx}  Commutative!Easy!Selfop!Nullop!Incdec,
                  {SUBx}              Easy!Selfop!Nullop!Incdec,
                  {MULx}  Commutative!Weak Assoc!Nullop,
                  {DIVx}         No Assoc!Nullop,
                  {EXPx}  InPrim!No Assoc!Nullop,
                  {ANDx}  Weak Assoc!Easy!Nullop!Selfop!Commutative,
                  {ORx}   Weak Assoc!Easy!Nullop!Selfop!Commutative,
                  {XORx}  Weak Assoc!Easy!Nullop!Selfop!Commutative,
                  {BICx}  Weak Assoc!Easy!Nullop!Selfop,
                  {ROTx}    No Assoc!Nullop,
                  {LSHx}    No Assoc!Nullop!Selfop,
                  {RSHx}    No Assoc!Nullop!Selfop,
                  {REMx}    No Assoc,
                  {MODx}    No Assoc,
                  {EXTx}    No Assoc,
                  {MULHx}   No Assoc,
                  {UDIVx}   No Assoc,
                  {UREMx}   No Assoc,
                  {CONCx}   No Assoc,
                  {RNEGx}   No Assoc!Unary!Selfop,
                  {RABSx}   No Assoc!Unary,
                  {RADDx}   No Assoc!Commutative,
                  {RSUBx}   No Assoc,
                  {RMULx}   No Assoc!Commutative,
                  {RDIVx}   No Assoc,
                  {REXPx}   No Assoc!Inprim

   %constintegerarray Easy Op(ADDx:BICx) =
                  {ADDx} ADD,
                  {SUBx} SUB,
                  {MULx}   0,
                  {DIVx}   0,
                  {EXPx}   0,
                  {ANDx} AND,
                  {ORx}  ORR,
                  {XORx} EOR,
                  {BICx} BIC

   %constintegerarray Null Value(ADDx:RSHx) =
                  0, {ADDx}   0, {SUBx}   1, {MULx}
                  1, {DIVx}   1, {EXPx}  -1, {ANDx}
                  0, {ORx}    0, {XORx}   0, {BICx}  0, {ROTx}
                  0, {LSHx}   0  {RSHx}

{Condition codes}

   %constinteger  EQ = 1,   LT = 2,   GT = 4,   TT = 8,  Always = 7,
                  NE = 6,   LE = 3,   GE = 5,   FF = 9,  Never  = 0

   %constbytearray Reverse(Never:FF) = Never,
                                       EQ {EQ},  GT {LT},  GE {LE},
                                       LT {GT},  LE {GE},  NE {NE},
                                       Always,   TT {TT},  FF {FF}

   %constbytearray Negated(Never:FF) = Always,
                                       NE {EQ},  GE {LT},  GT {LE},
                                       LE {GT},  LT {GE},  EQ {NE},
                                       Never,    FF {TT},  TT {FF}

{Otypes}

   %constinteger  Own      = 1,        EqualsEquals =  1,
                  Con      = 2,        Equals       =  0,
                  External = 3,        Jam          = -1,
                  System   = 4,
                  Dynamic  = 5,
                  Primrt   = 6,
                  Permrt   = 7

{Procedure end codes}

   %constinteger  Map     = -2,
                  Fn      = -1,               {negative implies stacked result}
                  Routine =  0,
                  True    =  1,
                  False   =  2


   %integer    J, NN
   %owninteger Code            = 0,            {current I-code symbol}
               Pending         = 0,            {next I-code symbol}
               Pending Tag     = 0,            {optimise 0<=N<=...}
               Pending Lit     = 0,
               Pending Auto N  = 0,
               Pending Auto    = 0,
               Pending Auto Ca = 0,
               Language Flags  = 0,
               Stack Check     = 0,            {entry for external}
               Falign          = 0             {worst internal alignment}

   %owninteger Invert      = 0,
               Unsigned    = 0,
               Free Label

   %constinteger Defined    = 16_8000 0000,
                 Label Mask = \Defined,
                 Inverted   = 1

   %recordformat Knowfm(%byte                Ftype, Reg, Base, Oper,
                        %integer             Disp, Area, Opnd, Extra,
                        %record(Knowfm)%name Link)
   %constrecord(Knowfm)%name KnowfmType == 0

   %recordformat Labelfm(%integer Lab, %record(Knowfm)%name Env)

   %recordformat Ilabelfm(%record(Ilabelfm)%name Link,
                          %record(Labelfm)%array Lab(0:255))
   %constrecord(Ilabelfm)%name Ilabelfm Type == 0
   %record(Ilabelfm)%name Ilabel List == NIL

!0.9!   %record(Ilabelfm)%namearray Ilabels(0: Max Label>>8)
{0.9}   %recordformat IlabelPfm(%record(Ilabelfm)%name Label)
{0.9}   %record(IlabelPfm)%array Ilabels(0:Max Label>>8)

   %ownrecord(Knowfm)%name   Knowing            == 0,
                             Kasl               == 0
   %ownintegerarray          Ktimes(0:AnyF)      = 0(*)

   %owninteger               Used Time = 0
   %ownintegerarray          Used(0:AnyF)      = 0(*)
   %ownintegerarray          Activity(0:AnyF)  = 0(*)
   %owninteger               Active Registers = 0

   %integer                  Pending Known Register = 0
   %record(Stackfm)          Pending Known

   %ownstring(127)         Alias               = "",      {003}
                           Internal Id         = "",
                           External Id         = "",
                           Section  Id         = ""

   %owninteger             Decl Size,
                           Vlb, Vub,
                           Ostate,
                           OwnType,
                           OwnForm,
                           Ownextra,
                           Constant Type,
                           Init Flag = 0

   %record(Varfm)%name     DefV
   %record(Varfm)          AltV
   %owninteger             Parms
   %owninteger             Section    = 0

   %owninteger   Control        = 0,  {Unass Check}
                 Unassigned     = 0,  {#0 for unassigned checks}
                 Compiling Prim = 0   {#0 when compiling PRIM file}

{Forms}

   %constinteger Address  = 0,
                 Direct   = Address+1,
                 AutoI    = 2,               Memorable Limit = AutoI,
                 AutoD    = 3,
                 Proc     = 4,
                 LabelX   = 5,
                 Indirect = 15               {**only for VARs**}

   %conststring(6)%array FormId(Address:LabelX) = "addr", "value", "()+",
                                                   "-()",  "proc",  "label"

{Prim routines}

   %constinteger  Signal       =  1,        {%signal}
                  Cscomp       =  2,        {compare string & constant}
                  Sres         =  3,        {string resolution}
                  Sw Jump      =  4,        {switch jump}
                  Intexp       =  5,        {integer exponentiation}
                  RealExp      =  6,        {real exponentiation}
                  Genmove      =  7,        {general string move}
                  Sconc        =  8,        {string concatenation}
                  Scomp        =  9,        {string comparison}
                  Sjam         = 10,        {string jam transfer, length known}
                  SetIn        = 11,        {test for R0 IN (R3)}
                  Resflop      = 12,        {string resolution fails}
                  TestNil      = 13,        {Nil, Unassigned & Disposed}
                  MakeLocal    = 14,        {copy array into local space}
                  Aref         = 15,        {n-dim array reference}
                  Dynamic Range= 16,        {Check R2 <= R1 <= R3}
                  Dynamic N    = 17,        {n-dim array declaration}
                  Frag1        = 18,        {assign resolution fragment 1}
                  RtMonitor    = 19,        {invoke run-time monitor}
                  Set Bit      = 20,        {bit -> 1 in set}
                  Captest      = 21,        {test for capacity exceeded}
                  Ass Test     = 22,        {unassigned test}
                  Trace Line   = 23,        {line trace debugger}
                  Frag2        = 24,        {assign resolution fragment 2}
                  Clear Bit    = 25,        {bit -> 0 in set}
                  Test New     = 26,        {fail if variant NEW}
                  Nil Test     = 27,        {Test for NIL pointer}
                  Set Bits     = 28,        {set multiple bits in SETs}
                  Set Add      = 29,
                  Set Sub      = 30,
                  Set Inter    = 31,
                  Set GE       = 32,
                  Check Range  = 33,
                  Test MOD     = 34,        {check for a MOD (<=0)}
                  Clear Bits   = 35,        {clear multiple bits in set}
                  Test Variant = 36,
                  Prim Mul     = 37,
                  Prim Div     = 38,
                  Test Real    = 39,        {compare real with zero}
                  Prim Compare = 40,
                  Real Intpt   = 41,
                  Modulus      = 42,
                  Dynamic 1    = 43,        {single-dimension dynamic array}
                  Dynamic 2    = 44,        {two-dimensional dynamic array}
                  Psymbol      = 45,        {printsymbol}
                  Set Range    = 46,        {check set ranges}
                  ReadCh       = 47,        {readsymbol in prim}
                  NextCh       = 48,        {nextsymbol in prim}
                  Prim Udiv    = 49,        {unsigned divide}
                  Set Zero     = 50,        {test for null set}
                  Set Equal    = 51,        {test for set equality}
                  Real Int     = 52,        {int(F0) -> R0}
                  Real Round   = 53,        {round(F0) -> R0}
                  CallP        = 54,        {call proc parameter}
                  Enter P      = 55,        {jump to procedure}
                  Dalloc       = 56         {dynamic allocation & unassign}

   %constinteger Last Prim = 56

   %owninteger    Enter Proc = 0          {filled in on first use}

   %constintegerarray Corrupts(Signal:Last Prim) =
             {FFFF FFFF A RRRR RRRR RRRR RRRR }
             {7654 3210   FEDC BA98 7654 3210 }
            2_0000 0000 0 0000 0000 0000 0000,        { 1:signal}
            2_0000 0000 0 0000 0000 0000 0001,        { 2:cscomp}
            2_0000 0000 0 0001 0001 1111 1111,        { 3:Sres}
            2_0000 0000 0 0000 0000 0000 0000,        { 4:swjump}
            2_0000 0000 0 0000 0000 0010 1111,        { 5:intexp}
            2_0000 0011 0 0000 0000 0000 0001,        { 6:realexp}
            2_0000 0000 0 0000 1111 1111 1111,        { 7:rtraceproc}
            2_0000 0000 0 0000 0000 0011 1100,        { 8:Sconc}
            2_0000 0000 0 0000 0000 0111 1110,        { 9:scomp}
            2_0000 0000 0 0000 0000 0000 1111,        {10:sjam}
            2_0000 0000 0 0000 0000 0000 1001,        {11:SetIn}
            2_0000 0000 0 0000 0000 0000 0000,        {12:ResFlop}
            2_0000 0000 0 0000 0000 0000 0111,        {13:sconc opt}
            2_0000 0000 0 0000 0000 0000 1111,        {14:MakeLocal}
            2_0000 0000 0 0000 0000 0000 0000,        {15:aref}
            2_0000 0000 0 0000 0000 0000 0000,        {16:Dynamic Range}
            2_0000 0000 0 0000 1000 1110 1111,        {17:dynamic n}
            2_0000 0000 0 0000 0000 1000 0111,        {18:Frag1}
            2_0000 0000 0 0000 0000 0000 0000,        {19:rtmonitor}
            2_0000 0000 0 0000 0000 0001 1001,        {20:set bit}
            2_0000 0000 0 0000 0000 0000 0000,        {21:captest}
            2_0000 0000 0 0000 0000 0000 0000,        {22:asstest}
            2_0000 0000 0 0000 1111 1111 1111,        {23:traceline}
            2_0000 0000 0 0000 0000 0100 1101,        {24:Frag2}
            2_0000 0000 0 0000 0000 0001 1001,        {25:Clear bit}
            2_0000 0000 0 0000 0000 0000 0000,        {26:Test New}
            2_0000 0000 0 0000 0000 0000 0000,        {27:Nil test}
            2_0000 0000 0 0000 0000 0011 1010,        {28:Set Bits}
            2_0000 0000 0 0000 1001 1111 1111,        {29:Set Add}
            2_0000 0000 0 0000 1001 1111 1111,        {30:Set Sub}
            2_0000 0000 0 0000 1001 1111 1111,        {31:Set Inter}
            2_0000 0000 0 0000 1001 1111 1111,        {32:Set GE}
            2_0000 0000 0 0000 0000 0000 0000,        {33:Check Range}
            2_0000 0000 0 0000 0000 0000 0000,        {34:test mod}
            2_0000 0000 0 0000 0000 0011 1010,        {35:Clear Bits}
            2_0000 0000 0 0000 0000 0000 0000,        {36:Test Variant}
            2_0000 0000 0 0000 0000 0000 0011,        {37:prim mul}
            2_0000 0000 0 0000 0000 0011 1111,        {38:prim div}
            2_0000 0000 0 0000 0000 0000 0000,        {39:test real}
            2_0000 0000 0 0000 0000 0001 1111,        {40:primcomp}
            2_0000 0010 0 0000 0000 0000 0001,        {41:intpt}
            2_0000 0000 0 0000 0000 0011 1110,        {42:modulus}
            2_0000 0000 0 0000 0001 1111 1111,        {43:dynamic 1}
            2_0000 0000 0 0000 0000 1111 1111,        {44:dynamic 2}
            2_0000 0000 0 0001 1111 1111 1101,        {45:Psymbol}
            2_0000 0000 0 0000 0000 0011 1000,        {46:Set Range}
            2_0000 0000 0 0000 0011 1111 1111,        {47:ReadCh}
            2_0000 0000 0 0000 0011 1111 1111,        {48:NextCh}
            2_0000 0000 0 0000 0000 0000 1111,        {49:prim udiv}
            2_0000 0000 0 0000 0001 1111 1110,        {50:set zero}
            2_0000 0000 0 0000 1001 1111 1111,        {51:set equal}
            2_0000 0011 0 0000 0000 0000 0001,        {52:Real Int}
            2_0000 0001 0 0000 0000 0000 0001,        {53:Real Round}
            2_0000 0000 0 0000 0000 0000 0000,        {54:CallP}
            2_0000 0000 0 0000 0000 0000 0000,        {55:EnterP}
            2_0000 0000 0 0001 1000 0001 0000         {56:Dalloc}    {004}

   %constintegerarray Prim Parameter(Signal:Last Prim) =
             {FFFF FFFF A RRRR RRRR RRRR RRRR }
             {7654 3210   FEDC BA98 7654 3210 }
            2_0000 0000 0 0000 0000 0000 0000,        { 1:signal}
            2_0000 0000 0 0000 0000 0000 0110,        { 2:cscomp}
            2_0000 0000 0 0001 1111 0001 1110,        { 3:Sres}
            2_0000 0000 0 0000 0000 0000 0010,        { 4:swjump}
            2_0000 0000 0 0000 0000 0000 0110,        { 5:intexp}
            2_0000 0001 0 0000 0000 0000 0001,        { 6:realexp}
            2_0000 0000 0 0000 0000 0000 0000,        { 7:traceproc}
            2_0000 0000 0 0000 0000 0000 1100,        { 8:Sconc}
            2_0000 0000 0 0000 0000 0000 0110,        { 9:scomp}
            2_0000 0000 0 0000 0000 0000 0111,        {10:sjam}
            2_0000 0000 0 0000 0000 0000 0110,        {11:SetIn}
            2_0000 0000 0 0000 0000 0000 0000,        {12:ResFlop}
            2_0000 0000 0 0000 0000 0000 0111,        {13:sconc opt}
            2_0000 0000 0 0000 0000 0000 0111,        {14:MakeLocal}
            2_0000 0000 0 0000 0000 0000 0000,        {15:aref}
            2_0000 0000 0 0000 0000 0000 1110,        {16:Dynamic Range}
            2_0000 0000 0 0000 1000 0000 0110,        {17:dynamic n}
            2_0000 0000 0 0001 0000 1000 0110,        {18:Frag1}
            2_0000 0000 0 0000 0000 0000 0000,        {19:rtmonitor}
            2_0000 0000 0 0000 0001 0000 0010,        {20:set bit}
            2_0000 0000 0 0000 0000 0000 0000,        {21:captest}
            2_0000 0000 0 0000 0000 0000 0000,        {22:asstest}
            2_0000 0000 0 0000 0000 0000 0000,        {23:traceline}
            2_0000 0000 0 0001 0000 0100 1100,        {24:Frag2}
            2_0000 0000 0 0000 0001 0000 0010,        {25:clear bit}
            2_0000 0000 0 0000 0000 0000 0000,        {26:Test New}
            2_0000 0000 0 0000 0000 0000 0010,        {27:Nil test}
            2_0000 0000 0 0000 0001 0000 0011,        {28:Set Bits}
            2_0000 0000 0 0000 1001 0000 0000,        {29:Set Add}
            2_0000 0000 0 0000 1001 0000 0000,        {30:Set Sub}
            2_0000 0000 0 0000 1001 0000 0000,        {31:Set Inter}
            2_0000 0000 0 0000 1001 0000 0000,        {32:Set GE}
            2_0000 0000 0 0000 0000 0000 1010,        {33:Check Range}
            2_0000 0000 0 0000 0000 0000 0000,        {34:test mod}
            2_0000 0000 0 0000 0001 0000 0011,        {35:Clear Bits}
            2_0000 0000 0 0000 0000 0000 1010,        {36:Test Variant}
            2_0000 0000 0 0000 0000 0000 0011,        {37:prim mul}
            2_0000 0000 0 0000 0000 0000 0110,        {38:prim div}
            2_0000 0000 0 0000 0000 0000 0000,        {39:test real}
            2_0000 0000 0 0000 0000 0000 0111,        {40:primcomp}
            2_0000 0000 0 0000 0000 0000 0011,        {41:intpt}
            2_0000 0000 0 0000 0000 0000 0110,        {42:prim div}
            2_0000 0000 0 0000 0000 0011 1000,        {43:dynamic 1}
            2_0000 0000 0 0000 0001 1101 1000,        {44:dynamic 2}
            2_0000 0000 0 0000 0000 0000 0010,        {45:Psymbol}
            2_0000 0000 0 0000 0000 0000 0111,        {46:Set Range}
            2_0000 0000 0 0000 0000 0000 0000,        {47:ReadCh}
            2_0000 0000 0 0000 0000 0000 0000,        {48:NextCh}
            2_0000 0000 0 0000 0000 0000 0110,        {49:prim udiv}
            2_0000 0000 0 0000 0000 0000 0001,        {50:set zero}
            2_0000 0000 0 0000 0000 0000 0011,        {51:set equal]
            2_0000 0001 0 0000 0000 0000 0001,        {52:Real Int}
            2_0000 0001 0 0000 0000 0000 0000,        {53:Real Round}
            2_0000 0000 0 0000 0000 0000 0000,        {54:CallP}
            2_0000 0000 0 0000 0000 0000 0000,        {55:EnterP}
            2_0000 0000 0 0000 0000 0001 0000         {56:Dalloc}

{File data}

   %constinteger Icode = 1

   %owninteger Last Dir = 0,
               Refs     = 0,  Blocks = 0

{Areas}

   %constinteger     Code Area = 0<<8,
                      Own Area = 1<<8,
                 Constant Area = 2<<8,
                Own Array Area = 3<<8

   {============================================================}

   %owninteger        Own Base =  0,            {current own area address}
                      Min SB   =  0,            {backward offset into SB}
                Own Array Base =  0,
                 Constant Base =  0,            {current constant area address}
                  Current Area =  Code Area,    {currently selected area}
                     Last Area =  0,
                   External No =  0

   %constinteger Base Local = 128

   %ownintegerarray Frame Use(Base Local:Base Local+Max Nesting) = 0(*)
   %owninteger Fmark = 0

   %record(Stackfm)       Uapat, Zero, One, SpV
   %record(Stackfm)%array RegV(None:AnyF)

   %record(Varfm)%name     For Range == Nil    {## Nil if check required}

   %record(Stackfm)    C255 = 0;  C255_Disp = 255;  C255_Type = Integers
   %constinteger          No Danger = 16_7FFF          {>> than 128+depth}
   %owninteger            Jamit= 0, Entry Point = -1,
                          Danger Level    = No Danger  {limit of normal globals}

   %string(127) Include File = ""

   %integer Dtype      {for remembering disag type on arrays}

   %recordformat Qfm(%integer Type, Size, Round, Bias, Dim, Format,
                              Diags, Dtype, Dform, Ind,
                     %record(Qfm)%name Pointed)

   %recordformat Diag Fm(%record(Diagfm)%name Link,
                         %record(Varfm)%name  Var,
                         %integer             X, Xtype,
                                              Format,
                                              Ext,
                         %string(127)         Id)            {003}

   %constrecord(Diagfm)%name Diagfm Type == 0
   %record(Diagfm)%name Diag List == Nil

   %constinteger Display Limit = 128+17
   %ownshortarray Display Vector(128:Display Limit) = 0(*)

   %owninteger Cp = 0
   %bytearray Code Buffer(0:255)

   %recordformat Vvfm(%record(Vvfm)%name Link, %record(Varfm)%array V(0:63))
   %constrecord(Vvfm)%name VvfmType == 0
   %record(Vvfm)%name Var List == NIL
   %recordformat Pvfm(%record(Vvfm)%name P)
   %record(Pvfm)%array Pvar(0:Var Top)

   %record(Varfm)%map Var(%integer A)
      %record(Vvfm)%name V
      %record(Pvfm)%name X
      X == Pvar(A>>6)
      %if X_P == Nil %start
         V == NEW(VvfmType)
         V_Link == Var List;  Var List == V
         X_P == V
      %finish
      %result == X_P_V(A&63)
   %end

   %routine Flush Code
      %integer J
      %return %if Cp = 0
      Printsymbol(Dir Dump)
      Dump Encoded(Cp)
      Printsymbol(Code Buffer(J)) %for J = 1, 1, Cp
      Cp = 0
   %end

%routine Assemble(%record(Varfm)%name Avar,
                  %integer Amode, Vars, Local, Parameter List,
                  %integername Global Attributes)
{Amode = -16 - Initial call          }
{         -2 - Alternate format start}
{         -1 - Recordformat          }
{          0 - Procedure             }
{         >0 - Procedure spec        }
%routinespec             Not in Yet
%routinespec             Fail(%string(63) Why)
%routinespec             Warn(%integer Fault, %string(63) What)
%routinespec             Display(%record(Stackfm)%name V, %integer Bias)
%routinespec             Monitor(%record(Stackfm)%name V, %string(127) Text)
%predicatespec           Iconst(%record(Stackfm)%name V)
%predicatespec           Iconst Item(%record(Stackfm)%name V)
%predicatespec           Const(%record(Stackfm)%name V)
%predicatespec           Same(%record(Stackfm)%name A, B)
%predicatespec           InReg(%record(Stackfm)%name V)
%predicatespec           Floating(%record(Stackfm)%name V)
%integerfnspec           Power(%integer N)
%integerfnspec           Item Size(%integer T)
%record(Stackfm)%mapspec Register(%integer R)
%routinespec             Claim(%integer Register)
%routinespec             Release(%integer Register)
%routinespec             Release and Drop(%record(Stackfm)%name V)
%routinespec             Zap Index and Record(%record(Stackfm)%name V)
%routinespec             Release and Drop Pair(%record(Stackfm)%name A, B)
%routinespec             Hazard(%integer Register)
%routinespec             Pessimise(%record(Stackfm)%name V)
%routinespec             Forget(%integer Register)
%routinespec             Forget Destination(%record(Stackfm)%name V)
%routinespec             Forget Everything
%routinespec             Remember(%integer Register, %record(Stackfm)%name V)
%routinespec             Remember Zero(%integer Register)
%routinespec             Optimise(%record(Stackfm)%name V, %integer Mode)

%routinespec             Simplify(%record(Stackfm)%name V)
%routinespec             Amap(%record(Stackfm)%name V)
%routinespec             Vmap(%record(Stackfm)%name V, %integer Type)
%routinespec             Make AutoI(%record(Stackfm)%name V, %integer Type)
%routinespec             Advance(%record(Stackfm)%name V, %integer Type, By)
%routinespec             Load(%record(Stackfm)%name V, %integer Register)
%routinespec             Loadup(%record(Stackfm)%name V)
%routinespec             Load Address(%record(Stackfm)%name V, %integer R)
%routinespec             Loadup Address(%record(Stackfm)%name V)
%routinespec             Load Pair(%record(Stackfm)%name A, %integer Ar,
                                   %record(Stackfm)%name B, %integer Br)
%routinespec             Load Trio(%record(Stackfm)%name A, %integer Ar,
                                   %record(Stackfm)%name B, %integer Br,
                                   %record(Stackfm)%name C, %integer Cr)
%routinespec             Pop Stack(%integer Bytes)
%routinespec             Load Protected(%record(Stackfm)%name V)
%routinespec             Move(%record(Stackfm)%name From, To)
%routinespec             Move Literal(%integer Lit, %record(Stackfm)%name V)
%routinespec             Store(%record(Stackfm)%name From, To)
%routinespec             Store Address(%record(Stackfm)%name From, To,
                                       %integername Extra)
%routinespec             Operate(%integer Op, %record(Stackfm)%name L, R)
%routinespec             Compare(%record(Stackfm)%name L, R)
%integerfnspec           New Label
%routinespec             Jump To(%integer Internal Label, Cond Code)
%routinespec             Define Label(%integer Internal Label)
%routinespec             Test Zero(%record(Stackfm)%name V)
%routinespec             Test Range(%record(Stackfm)%name V,
                                    %record(Varfm)%name R)
%routinespec             Clear Vars(%integer Limit)
%routinespec             DIR String(%integer Op, %string(*)%name S)
%routinespec             Float(%record(Stackfm)%name V, %integer R)
%routinespec             Dump External(%integer C, %record(Varfm)%name V)
%routinespec             Do(%string(31) Ident, %integername Ep, %integer Result)

%integerfnspec           GPR
%integerfnspec           FPR
%integerfnspec           Select Best(%record(Stackfm)%name From, To, %integer D)
%record(Stackfm)%mapspec Descriptor
%record(Stackfm)%mapspec Temporary
%routinespec             Drop(%record(Stackfm)%name V)
%record(Stackfm)%mapspec Local Integer(%integer Disp)
%record(Stackfm)%mapspec Literal(%integer N)
%record(Stackfm)%mapspec Copy(%record(Stackfm)%name V)

%integerfnspec           Tag
%integerfnspec           Four Bytes

%routinespec             Prim(%integer N)
%routinespec             Dump Text(%integer Max)
%routinespec             Pass Parameters(%record(Stackfm)%name V,
                                         %integername X, %integer BaseReg)
%routinespec             Assign(%integer How)
%routinespec             String Assign(%record(Stackfm)%name From, To)
%routinespec             Set Assign(%record(Stackfm)%name From, To)
%routinespec             Evaluate String Expression(%record(Stackfm)%name V)
%routinespec             Record Assign(%record(Stackfm)%name From, To)
%record(Stackfm)%mapspec Claim Work Area(%integer Size, Type)
%routinespec             Flush Diags
%routinespec             Convert Format(%record(Stackfm)%name V, %integer Type)
%routinespec             To Short Real(%record(Stackfm)%name V)
%routinespec             Store Real Constant(%record(Stackfm)%name W)
%routinespec             Build Set(%record(Stackfm)%name S)
%routinespec             Drop Members(%record(Stackfm)%name S)

%owninteger Frame           = 0,
            Round           = 0
%integer    Aframe          = 0,                {array extension to frame}
            Parameter Frame = 0,
            Parameter Regs  = 0,
            String Result   = 0

%integer    Block Type  = 0,
            Code Base   = 0,
            Uncond Jump = -1,
            D,
            N,
            Parameter Mode,
            VarBase   = Vars,
            First Alt = Parms-1,
            Frame Base,
            Old Frame,
            Alt Align,         {Worst alignment of record alternatives}
            Frame Extra,       {putative padding at front of alternative}
            Max Frame          {largest alternative so far}

%integer    Assign Lock     = 1 {#0 to permit marking assigned permanently}

%integer    Attributes      = 0,
            At              = 0,
            Entry Mask      = 0,
            MyMark,
            Open            = Closed,   {assume cannot return}
            Event Label     = 0,
            Event Body      = 0,
            Event Bits      = 0,
            Wsp Save        = 0,    {frame address of where SP is saved}
            Danger Marker   = 0,    {=1 if the block is dangerous}
            Local Display   = 0,    {#0 if in a dangerous block}
            Jlab,
            Array Base      = 0     {#0 if allocated}

   %integer Work Base = Last Work

%integername Ca == Code Base      {current Address}

%string(127) Proc Id = Internal Id                {003}

%record(Withfm)%name Withs == Nil

%conststring(*) Monitor Id = "3L___monitor"
%owninteger     Monitor Ep = 0

%routine Decode(%integer Word, At)
   %externalroutinespec D %alias "DECODE_ARM"(%integer W, A)
   Select Output(Report)
   D(Word, At)
   Select Output(Directives Out)
%end

%record(Stackfm)%map Display Info(%integer Base)
   %integer N
   %record(Stackfm)%name T
   %if Base < Danger Level %start               {the safe case}
      Frame Use(Base) = 0                       {show the level used}
      N = Display Vector(Base)
      %if N = 0 %start
         Min SB = Min SB-4;  N = Min SB
         Display Vector(Base) = N
      %finish
      T == Literal(N)
      T_Form  = Direct
      T_Base  = Sb
   %else                                        {the dangerous case - p-params}
      T == Local Integer(Local Display+4*(Base-Danger Level))
   %finish
   Attributes = Attributes!Attr Needs Display ! Attr Needs Gp
   T_Flags = T_Flags!Known Ass
   %result == T
%end

%routine BD(%integer Base, Disp)
   Write(Disp, 1)
   Printsymbol('(')
   %if None <= Base <= AnyF %start
      Printstring(Regid(Base))
   %else
      %if Base >= Base Local %start
         %if Base = Local %start
            Printstring("Fp")
         %else
            Printsymbol('L')
            Base = Base-Base Local-1
            Write(Base, 0)
         %finish
      %else
         Write(Base, 0)
      %finish
   %finish
   Printsymbol(')')
%end

%routine Show(%integer N, %string(15) Text)
   %if N # 0 %start
      Space;  Printstring(Text)
      Write(n, 1)
   %finish
%end

%routine Show Data(%record(Stackfm)%name V, %integer Left)
   Spaces(Left);  Printstring(Typeid(V_Type))
   Space;         Printstring(Formid(V_Form))
   BD(V_Base, V_Disp)
   Show(V_Format, "Fm:")
   Show(V_Area,   "A:")
   Show(V_Flags,  "Fl:")
      PrintSymbol('R') %if V_Flags&By Ref     # 0
      PrintSymbol('A') %if V_Flags&Array      # 0
      PrintSymbol('N') %if V_Flags&Arrayname  # 0
      PrintSymbol('P') %if V_Flags&Parameter  # 0
      PrintSymbol('D') %if V_Flags&Defered    # 0
      PrintSymbol('W') %if V_Flags&Awanted    # 0
      PrintSymbol('S') %if V_Flags&Static     # 0
      PrintSymbol('=') %if V_Flags&Known Ass  # 0
      Printsymbol('H') %if V_Flags&Hazarded   # 0
      Printsymbol('X') %if V_Flags&Xproc Spec      # 0
      Printsymbol('n') %if V_Flags&Nasty Proc # 0
      Printsymbol('C') %if V_Flags&Checkable  # 0
   PrintSymbol('#') %and Write(V_Varno, 0) %if V_Varno # 0
   %if V_Record ## Nil %start
      Newline
      Spaces(Left);  Printstring("  _:")
      Display(V_Record, Left+4)
   %finish
   %if V_Index ## Nil %start
      Newline
      Write(V_Xsize, Left+2);  Printstring("i:")
      Display(V_Index, Left+4)
   %finish
%end

%routine Display(%record(Stackfm)%name V, %integer Bias)
   %if V == Nil %start
      Printstring(" Nil");  Newline
      %return
   %finish
   Show Data(V, Bias)
   newline
   %if V_Oper # 0 %start
      Spaces(Bias-4);  Printstring(Operid(V_Oper))
      Display(V_Link, Bias+4)
   %finish
%end

%routine Show Reg(%integer R)
   %integer A
   A = Activity(R)
   Printstring(Regid(R))
   %if A = 0 %start
      Printstring(" unused")
   %else %if A < 0
      %if A = -1 %start
         Printstring(" locked")
      %else
         Printstring(" =");  Printstring(Regid(-A));  Spaces(2)
      %finish
   %else
      Printstring(" used*");  Write(A, -1)
   %finish
   Printstring("  u:");     Print Hex(Used(R), 5)
   Printstring("  k:");     Write(Ktimes(R), 0)
   Newline
%end

%routine Monitor N(%integer N, %string(255) Text)
   Select Output(Report)
   Printstring(Text)
   Write(N, 8)
   Newline
   Select Output(Directives Out)
%end

%routine Monitor Register(%integer R, %string(127) Text)
   Select Output(Report)
   Printstring(Text);  Spaces(9-length(Text));  Space
   Show Reg(R)
   Select Output(Directives Out)
%end

%routine Monitor(%record(Stackfm)%name V, %string(127) Text)
   Select Output(Report)
   Printstring(Text);  Spaces(9-length(Text));  Space
   Display(V, 6)
   Select Output(Directives Out)
%end

%routine Mon Regid(%integer R, %string(127) Text)
   Select Output(Report)
   Printstring(Regid(R));  Space
   Printstring(Text)
   Newline
   Select Output(Directives Out)
%end

%routine Display Knowledge
   %record(Knowfm)%name K
   Select Output(Report)
   K == Knowing
   %while K ## Nil %cycle
      Printstring(Regid(K_Reg));  Printstring(" = ")
      Printstring(Typeid(K_Ftype>>4));  Space
      Printstring(Formid(K_Ftype&15));  Space
      BD(K_Base, K_Disp)
      %if K_Extra # 0 %start
         Printstring(" X:");  Write(K_Extra, 1)
      %finish
      %if K_Area # 0 %start
         Printstring(" A:");  Write(K_Area, 1)
      %finish
      %if K_Oper # 0 %start
         Space;  Printstring(OperId(K_Oper))
         Write(K_Opnd, 1)
      %finish
      Newline
      K == K_Link
   %repeat
   Select Output(Directives Out)
%end

%routine Show Where
   Select Output(Report)
   Printstring(" at line ");  Write(Current Line, 0)
   Printstring(" in file ".Include File) %if Include File # ""
   newline
%end

%routine Fail(%string(63) Why)

   %routine Pcode(%integer S)
      %if S >= 128 %start
         Printstring("128+")
         S = S-128
      %finish
      %if ' ' <= S <= 126 %start
         Printsymbol('''');  Printsymbol(S);  Printsymbol('''')
      %finish
      write(S, 3)
   %end

   %routine Err(%integer Stream)
      %integer R
      %record(Stackfm)%name U, S
      Select Output(Stream)
      Newline
      Printstring("====> Pass 2 fails -- ");  Printstring(Why)
      Show Where
      Printstring("Code ");      Pcode(Code)
      Printstring(" Pending ");  Pcode(Pending)
      Newline
      %for R = R0, 1, R15 %cycle
         Show Reg(R) %unless Activity(R) <= 0
      %repeat
      S == Stack
      %while S ## Nil %cycle
         Printstring("S:");  Display(S, 5)
         S == S_Stack
      %repeat
      U == Using
      %while U ## Nil %cycle
         Printstring("U:");  Display(U, 5)
         U == U_Using
      %repeat
      Newline
      %monitor
   %end
   Err(Report)                            {terminal}
   Err(Listing)                            {listing}
   %stop
%end

%routine Warn(%integer Fault, %string(63) What)
   Select Output(Report)
   Interface_Faults = Interface_Faults+Fault
   %if Fault = 0 %then Printstring("Warning: ") -
                 %else Printstring("*Error: ")
   Printstring(What)
   Show Where
   Select Output(Directives Out)
%end

%routine Not in Yet
   Fail("***Not implemented yet***")
%end

%routine Dir1(%integer Code)
   Flush Code
   Printsymbol(Code)
   Pending Auto = 0
%end

%routine Dir2(%integer Code, Arg1)
   Flush Code
   Printsymbol(Code)
   Dump Encoded(Arg1)
   Pending Auto = 0 %unless Code = Dir Line
%end

%routine Dir3(%integer Code, Arg1, Arg2)
   Flush Code
   Printsymbol(Code)
   Dump Encoded(Arg1)
   Dump Encoded(Arg2)
   Pending Auto = 0
%end

%routine Dir4(%integer Code, Arg1, Arg2, Arg3)
   Flush Code
   Printsymbol(Code)
   Dump Encoded(Arg1)
   Dump Encoded(Arg2)
   Dump Encoded(Arg3)
   Pending Auto = 0
%end

%record(Workfm)%map Work Area(%integer N)
   %record(WorkVfm)%name W
   %integer E, S, X
   %on * %start
      E = Event_Event;  S = Event_Sub;  X = Event_Extra
      Fail("too many work areas:".itos(E, 0))
   %finish
   Monitor N(N, "work area") %if Diag&MonOperand # 0
   W == Work List
   %while N > 30 %cycle
      N = N-30
      %if W_Link == NIL %start
         W_Link == NEW(WorkVfmType)
         W_Link = 0
      %finish
      W == W_Link
   %repeat
   %result == W_W(N)
%end

%record(Labelfm)%map Ilabel(%integer N)
   %integer X, J
   %record(Ilabelfm)%name I
   %record(Labelfm)%name L
   Fail("internal label/1") %if N > Max Label
   X = N>>8
!0.9!   I == Ilabels(X)
{0.9}   I == Ilabels(X)_Label
   %if I == NIL %start
      I == New(Ilabelfm Type)
!0.9! Ilabels(X) == I
{0.9} Ilabels(X)_Label == I
      I_Link == Ilabel List;  Ilabel List == I
      %for J = 0, 1, 255 %cycle
         L == I_Lab(J)
         L_Lab = Defined
         L_Env == NIL
      %repeat
   %finish
   %result == I_Lab(N&255)
%end

%routine Select Area(%integer Area Id, %integername Base)
   Dir3(Dir Area, Area Id>>8, Base)
   Current Area = Area Id
   Ca == Base
%end

%routine Select Code Area
   Select Area(Code Area, Code Base)
%end

%routine Select Constant Area
   Select Area(Constant Area, Constant Base)
%end

%routine Select Own Area
   Select Area(Own Area, Own Base)
%end

%routine Select Own Array Area
   Select Area(Own Array Area, Own Array Base)
%end

%include "inc.Plant"
%include "inc.Load"
%include "inc.Repeat"

%integerfn Cheapest(%integer Low, High)
   %integer R, A, U
   %integer Min Activity,
            Min Known,
            Min Reg,       {default to R3 or F3}
            Oldest

   Min Activity = 1000
   Min Known    = 1000
   Min Reg      = 0
   Used Time    = Used Time+1
   Oldest       = Used Time
   %for R = Low, 1, High %cycle
      A = Activity(R);  %continue %if A < 0                    {locked}
      U = Used(R)
      %if A = Min Activity %start
         %if Min Known > Ktimes(R) %start
            Min Reg   = R
            Min Known = Ktimes(R)
            Oldest    = U
         %else %if Min Known = Ktimes(R)
            %if Oldest > U %start             {choose the oldest}
               Min Reg = R
               Oldest  = U
            %finish
         %finish
      %else %if A < Min Activity
         Min Activity = A
         Min Reg      = R
         Min Known    = Ktimes(R)
         Oldest       = U
      %finish
   %repeat
   Fail("all registers lost") %if Min Reg = 0
   Used(Min Reg) = Used Time
   Hazard(Min Reg) %unless Min Activity = 0
   %result = Min Reg
%end

%integerfn GPR
   %result = Cheapest(R0, R8)
%end

%integerfn FPR
   %result = Cheapest(F0, F7)
%end

%record(Stackfm)%map Register(%integer Reg)
   %record(Stackfm)%name R
   R == Descriptor
   %if Reg = Any %start
      R_Type = Integers
      Reg    = Cheapest(R0, R8)
   %else %if Reg = AnyF
      R_Type = Lreals
      Reg    = Cheapest(F0, F7)
   %else
      R_Type = Integers
      R_Type = Lreals %if Reg >= F0
   %finish
   R_Base = Reg;  Claim(Reg)
   %result == R
%end

%predicate Locked(%integer R)
   %true %if R >= 128 %or R = 0 %or Activity(R) < 0
   %false
%end

%predicate Properly Aligned(%record(Stackfm)%name V, %integer Mask)
   %true %if V_Type = Sets
   %if V_Type = Records %start
      %false %if V_Format >= 0
      %true  %if Var(-V_Format)_Disp = 3    {format needs word alignment}
   %finish
   %false %unless Locked(V_Base)
   %true %if V_Form = Direct -
        %and V_Record == Nil -
        %and V_Index  == Nil -
        %and V_Disp&Mask = 0
   %false
%end

%include "inc.SIMPLIFY"

%routine Apply Index(%record(Stackfm)%name V, X, %integer Xsize)
   %integer N, MulOp
   %if Iconst(X) %and V_Form = Direct %start  {fold it in}
      N = V_Disp+X_Disp*Xsize
      V_Disp = N
      Drop(X)
      %return
   %finish
   %if V_Index == Nil %start                  {no index, just add the new one}
      V_Index == X;  V_Xsize = Xsize
   %else %if V_Xsize = Xsize                  {equal scaling}
      Operate(ADDx, V_Index, X)               {add in the new bit}
   %else                                      {different scaling}
      MulOp = MULx
      Operate(MulOp, V_Index, Literal(V_Xsize)) %unless V_Xsize = 1
      Operate(MulOp, X,       Literal(Xsize))   %unless   Xsize = 1
      Operate(ADDx, V_Index, X)
      V_Xsize = 1
   %finish
%end

%routine Fix Unitary String(%record(Stackfm)%name V)
   %integer Len, Val, At
   %owninteger Null Address = -1

   %integerfn Locate(%integer Len, Char)
      %integer Here
      Constant Base = (Constant Base+3)&(\3)
      Here = Constant Base
      Select Constant Area
      Dump Byte(Len);  Dump Byte(Char) %if Len # 0
      Select Code Area
      %result = Here
   %end

   %if V_Type = Strings %and V_Bias = 1 %start             {""}
      Null Address = Locate(0, 0) %if Null Address < 0
      At = Null Address
      Len = 1
   %else %if V_Type = Sets
      Build Set(V);  %return
   %else %if V_Type <= Addrs
      Val = V_Disp&255
      Warn(1, "string character out of range") %if Val # V_Disp
      At = Locate(1, Val)
      Len = 2
   %else
      Fail("bad tostring type")
   %finish
   V_Disp = At;  V_Type = Strings;  V_Form = Direct
   V_Area = Constant Area;  V_Format = Len;  V_Bias = Len
%end

%routine Amap(%record(Stackfm)%name V)
   %record(Stackfm)%name W
   %if V_Form = Address %start
      Fix Unitary String(V)
   %else %if V_Oper # 0
      Fail("Amap:oper")
   %finish
   V_Type = Integers          {all addresses are integers}
   %return %if V_Form = AutoD {special for the stack}

   %if V_Form = Proc %start
      %if V_Flags&Xproc Spec # 0 %start      {case 1 - an external}
         Hazard(R13);  Forget(R13)
         Dir2(Dir xThunk, V_Disp)            {         load @vector into R13}
         Refs = Refs+1;  Ca = Ca+4
         V_Type = Integers;  V_Form = Address
         V_Base = R13;       V_Disp = 0;  V_Area = 0
         Claim(R13)
      %else %if V_Flags&Parameter # 0        {case 2 - already a parameter}
         V_Type = Integers;  V_Form = Direct;  V_Area = 0
      %else %if V_Flags&XprocDef # 0         {case 3 - simplified}
         Hazard(R13);  Forget(R13)
         Dir2(Dir Thunk, V_Disp)             {         load @vector into R13}
         Refs = Refs+1;  Ca = Ca+4
         V_Type = Integers;  V_Form = Address
         V_Base = R13;       V_Disp = 0;  V_Area = 0
         Claim(R13)
      %else                                  {cases 3 & 4}
         Fail("cannot address local procedures")
      %finish
   %else
      Fail("Amap:form") %unless V_Form = Direct
      V_Form = Address
      %if V_Index ## Nil %and Iconst(V_Index) %start
         V_Disp = V_Disp+V_Index_Disp*V_Xsize
         Drop(V_Index);  V_Index == Nil
      %finish
      %if V_Disp = 0 %and V_Index == Nil %and V_Record ## Nil %start
         {convert addr 0(X) into X}
         W == V_Record
         V_Data = W_Data
         W_Index == Nil;  W_Record == Nil;  Drop(W)
      %finish
   %finish
   Monitor(V, "Amap<-") %if Diag&MonOperate # 0
%end

%routine Make AutoI(%record(Stackfm)%name V, %integer Type)
   Amap(V)            {get its address}
   Load Protected(V)  {to a safe register}
   V_Type = Type;  V_Form = AutoI
%end

%routine Vmap(%record(Stackfm)%name V, %integer New Type)
   %record(Stackfm)%name W, C
   %integer D = 0
   Fail("Vmap:type") %unless Integers <= V_Type <= Addrs
   %if V_Oper = ADDx %start
      C == V_Link
      %if Iconst(C) %start
         D = C_Disp
         Drop(C);  V_Link == NIL;  V_Oper = 0
      %finish
   %finish
   Loadup(V) %if V_Oper # 0   {PSR}
   %if V_Form # Address %start
      W == Descriptor;  W_Data = V_Data
      V_Data = 0
      V_Record == W
      V_Disp = D
   %finish
   V_Type   = Internal Type(New Type);  V_Form = Direct
   V_Format = Type Fmt(New Type)
   Monitor(V, "Vmap<-") %if Diag&MonOperate # 0
%end

%routine Fmap(%integer NewType)
   Hazard(Stack_Base) %if InReg(Stack)
   Fail("Bad type for Fmap") %unless Stack_Type = Integers -
                             %and    Stack_Form # Address
   Stack_Form = Proc
   Stack_Type = NewType
   Stack_Flags = Stack_Flags ! Answer ! Parameter
%end

%routine Advance(%record(Stackfm)%name V, %integer Type, By)
   %integer Check Flag
   %if V_Form # AutoD %start
      Check Flag = V_Flags&Checkable
      Amap(V)
      Operate(ADDx, V, Literal(By))
      Vmap(V, Type)
      V_Flags = V_Flags ! Check Flag
   %else
      V_Type = Type
   %finish
%end

%include "inc.Mcode"

%integerfn Uses(%integer R, %record(Stackfm)%name V)
   %integer N = 0
   %while V ## Nil %cycle
      N = N+1 %if V_Base = R
      N = N+Uses(R, V_Index) %unless V_Index == Nil
      N = N+Uses(R, V_Record) %unless V_Record == Nil
      V == V_Link
   %repeat
   %result = N
%end

%routine Store Real Constant(%record(Stackfm)%name W)
   %integer N
   %if W_Form = Address %and W_Base = 0      -
                        %and W_Record == Nil -
                        %and W_Index == Nil %start    {real constant}
      Constant Base = (Constant Base+3)&(\3)
      Select Constant Area
      N = Ca
      Dump Word(W_Rhigh)
      Dump Word(W_Rlow)
      Select Code Area
      W_Disp = N;  W_Area = Constant Area;  W_Form = Direct
   %finish
%end

%predicate Potentially Unassigned(%record(Stackfm)%name V)
   %false %if Unassigned = 0
   %false %if V_Flags&Known Ass # 0
   %false %unless V_Form = Direct %and V_Flags&Checkable # 0
   %true
%end

%routine Simple(%record(Stackfm)%name From, To)
   %record(Stackfm)%name W
   W == Copy(From)
   Move(W, To)
   Release and Drop(W)
%end

%routine Load Address(%record(Stackfm)%name V, %integer R)
   Amap(V)
   Load(V, R)
%end

%routine Push(%record(Stackfm)%name V)
   %record(Stackfm) S = 0
   S_Type = Integers;  S_Form = AutoD;  S_Base = SP
   Store(V, S)
%end

%routine Push Literal(%integer Lit)
   %record(Stackfm)%name L == Literal(Lit)
   Push(L)
   Release and Drop(L)
%end

%routine Push Address(%record(Stackfm)%name V)
   Amap(V)
   Push(V)
%end

%routine Pop Stack(%integer Bytes)
   %return %if Bytes = 0
   Fail("stack alignment") %if Bytes&3 # 0
   Plant1(ADD, Sp, Sp, Rot(Bytes>>2, 16-1))
%end

%routine Loadup Address(%record(Stackfm)%name V)
   Amap(V)
   Load(V, Any)
%end

%routine Loadup(%record(Stackfm)%name From)
   %integer Oper
   %record(stackfm)%name W, Lhs
   %if From_Type = Sets %start
      Fail("Bad set") %if From_Oper = 0
      Oper = From_Oper;  W == From_Link;  From_Oper = 0;  From_Link == NIL
      %if From_Flags&Work Set = 0 %start
         Lhs == Claim Work Area(Set Size, Sets);  Lhs_Flags = Lhs_Flags!Work Set
         Set Assign(From, Lhs)
         Release(From_Base)
         Zap Index and Record(From)
         From_Data = Lhs_Data
         Drop(Lhs)
      %finish
      Lhs == Copy(From)
      From_Oper = Oper;  From_Link == W
      Set Assign(From, Lhs)
      Release and Drop(Lhs)
   %else %if Floating(From)
      Load(From, AnyF)
   %else
      Load(From, Any)
   %finish
%end

%routine Load Protected(%record(Stackfm)%name V)
   {load V somewhere it can be altered safely}
   Monitor(V, "->Load protected") %if Diag&MonOperand # 0
   Loadup(V)
   %if Activity(V_Base) # 1 %start    {covers in use (>1) and locked (<0)}
      %if V_Type >= Reals %then Load(V, FPR) %else Load(V, GPR)
   %finish
   Monitor(V, "<-Load protected") %if Diag&MonOperand # 0
%end

%routine Constant Operation(%integer Op, %integername L,
                                         %record(Stackfm)%name R)
      %switch Cop(NOTX:REXPX)
      %integer N
      N = R_Disp;  Drop(R)
      ->Cop(Op)
Cop(ADDX):                                    L = L+N;        ->Out
Cop(SUBX):                                    L = L-N;        ->Out
Cop(MULHx):
Cop(MULX):                                    L = L*N;        ->Out
Cop(ANDx):                                    L = L&N;        ->Out
Cop(BICx):                                    L = L&(\N);     ->Out
Cop( ORX):                                    L = L!N;        ->Out
Cop(XORX):                                    L = L!!N;       ->Out
Cop(LSHX):                                    L = L<<N;       ->Out
Cop(RSHX):                                    L = L>>N;       ->Out
Cop(EXPX):   Fail("Exp") %if N < 0;           L = L\\N;       ->Out
Cop(MODx):   Fail("Illegal MOD") %if N <= 0
             %if L < 0 %start
                L = N-Rem(-L, N);  L = 0 %if L = N;           ->Out
             %finish
Cop(REMx):   Fail("Zero divide")  %if N = 0;  L = Rem(L, N);  ->Out
Cop(DIVX):   Fail("Zero divide")  %if N = 0;  L = L//N;       ->Out
Cop(*):      Fail("C-op")
Out:
%end

%routine Operate(%integer NewOper, %record(Stackfm)%name Lhs, Rhs)
   %integer Op, Rconst, Key, Lflags, Rflags, N, Fn
   %record(Stackfm)%name W

   %routine Swop
      %record(Stackfm) Temp
      Temp_Data = Lhs_Data
       Lhs_Data =  Rhs_Data
       Rhs_Data = Temp_Data
   %end

   %routine Zap
      {Make LHS = integer constant 0}
      Drop(W)
      Drop(Rhs)
      Lhs_Link == Nil;  Lhs_Oper = 0
      Rhs == Literal(0);  Swop;  Release and Drop(Rhs)
   %end

   %routine Reduce Constant
      %integer Op, N, F

      %routine Fix(%integer Op)
         Lhs_Oper = Op
         Drop(Lhs_Link)
         Lhs_Link == Nil
      %end

      Op = Lhs_Oper;  F = Oper Flags(Op)
      N = Lhs_Link_Disp
      %if F&Nullop # 0 %and Null Value(Op) = N %start
         Fix(0)
      %else %if Op = MULx
         %if N = 0 %start
            Fix(0)
            Release(Lhs_Base)
            Lhs_Form = Address;  Lhs_Base = None;  Lhs_Disp = 0;  Lhs_Area = 0
            Release and Drop(Lhs_Index) %if Lhs_Index ## Nil
            Release and Drop(Lhs_Record) %if Lhs_Record ## Nil
            Lhs_Record == Nil;  Lhs_Index == Nil
         %else %if N = -1
            Fix(NEGX)
         %finish
      %else %if Op = ADDx
        %if Lhs_Form = Address %start
            Fix(0);  Lhs_Disp = Lhs_Disp+N
        %finish
      %else %if Op = ANDx %and Lhs_Form = Direct %and Lhs_Area = 0
         N = N&255 %if Lhs_Type = Bytes
         %if Unassigned = 0 %or Lhs_Flags&Checkable = 0 -
                            %or Lhs_Flags&Known Ass # 0 %start
            {only do this if Lhs is not to be checked for unassigned}
            %if       N&16_FFFFFF00 = 0 %start
               Lhs_Type = Bytes
               Fix(0) %if N = 255
            %else %if N&16_FFFF00FF = 0 %and Lhs_Type = Shorts
               Lhs_Type = Bytes;  Lhs_Disp = Lhs_Disp+1
               N = N>>8;  Lhs_Link_Disp = N
               Fix(0) %if N = 255
               Operate(LSHx, Lhs, Literal(8))
            %finish
         %finish
      %else %if Op = XORX %and N = -1
         Fix(NOTX)
      %finish
   %end

   %integerfn Field(%integer And, Shift, AndFirst)
      %integer R = 0
      %if AndFirst # 0 %start              {X&And >> Shift}
         And = (And>>Shift)<<Shift
         %result = -1 %if And = 0          {zero result}
         And = And>>1 %and R = R+1 %while And&1 = 0
         %result = 0 %if Shift < R         {shift must equal R}
                                           {it's now in the form X>>Shift & And}
      %else                                {X>>Shift & And}
         And = (And<<Shift)>>Shift
         %result = -1 %if And = 0          {zero result}
      %finish
      N = Power(And+1);  %result = 0 %if N < 0 %or N > 8
      %result = N<<16 + Shift
   %end

   %if Diag&MonOperate # 0 %start
      Monitor(Lhs, "O-Lhs")
      Monitor(Rhs, "O-Rhs")
   %finish
   Rflags = Oper Flags(NewOper)
   %if Rflags&Unary # 0 %start
      %if Iconst(Lhs) %start                 {this excludes reals}
         %if NewOper = NEGX %start
            Lhs_Disp = -Lhs_Disp
         %else %if NewOper = NOTX
            Lhs_Disp = \Lhs_Disp
         %else %if NewOper = ABSx
            Lhs_Disp = |Lhs_Disp|
         %finish %else Fail("Operator")
      %else
         NewOper = NewOper+Real Shift %if Floating(Lhs)
         %if Lhs_Oper # 0 %start
            %if Lhs_Oper = NewOper %start      {e.g. -(-A) }
               {SCR/87/401}
               Lhs_Oper = 0 %unless NewOper = ABSx -
                                %or NewOper = RABSx  {BEWARE: ABS(ABS(X))}
               ->Mon
            %finish
            %if NewOper = NEGx %or NewOper = NOTx %start  {SCR/87/401}
               %if Lhs_Oper = NEGx %or Lhs_Oper = NOTx %start
                  { -(\A)  ->  A+1      Note:  -NEG = ADD }
                  { \(-A)  ->  A-1             -NOT = SUB }
                  Lhs_Oper = 0
                  %if NewOper = NEGx %then NewOper = ADDx %else NewOper = SUBx
                  Operate(NewOper, Lhs, Literal(1))
                  ->Mon
               %finish
            %finish
            %if NewOper = NEGx %and Lhs_Oper = MULx %and Iconst(Lhs_Link) %start
               %if Lhs_Link_Disp # Minus Infinity %start
                  Lhs_Link_Disp = -Lhs_Link_Disp
                  ->Mon
               %finish
            %finish
            Loadup(Lhs)
         %finish
         Lhs_Oper = NewOper;  Lhs_Link == Nil
      %finish
      ->Mon
   %finish

   %if NewOper = ConcX %start
      %if Rhs_Bias = 1 %start                  {s.""}
         Drop(Rhs);  %return
      %finish
      %if Lhs_Bias = 1 %start                  {"".S}
         Fail("inconsistent concatenation") %if Lhs_Link ## Nil
         Lhs_Data = Rhs_Data;  Drop(Rhs)
         %return
      %finish
      Loadup(Lhs) %if Lhs_Oper # 0 %and Lhs_Oper # CONCx
      Loadup(Rhs) %if Rhs_Oper # 0
      Lhs == Lhs_Link %while Lhs_Oper # 0      {skip to the end}
      Lhs_Oper = ConcX;  Lhs_Link == Rhs       {append the new bit}
      ->Mon
   %finish

   Swop %if Rflags&Commutative # 0 %and Iconst(Lhs) {1@? -> ?@1}

   %if Rhs_Oper # 0 %start
      Op = Rhs_Oper
      %if Op = NEGx %and (NewOper = ADDx %or NewOper = SUBx) %start
                                                  { Lhs + (-Rhs) }
         NewOper = (ADDx+SUBx)-NewOper            { Lhs - Rhs }
         Rflags = Oper Flags(NewOper)
         Rhs_Oper = 0
      %else %if Op = NOTx %and NewOper = ANDx     {convert to BIC}
         Rhs_Oper = 0;  NewOper = BICx
      %else %if (Op = LSHx %or Op = RSHx) %and Oper Flags(NewOper)&Easy # 0 -
                                          %and Lhs_Type < Reals             -
                                          %and Lhs_Oper < Rnegx
         {optimise A newoper B shift C}
         W == Rhs_Link;  Rhs_Link == NIL;  Rhs_Oper = 0
         Loadup(Lhs)
         Loadup(Rhs)
         %if Iconst(W) %start
            %if Op = LSHx %then N = Ishift(Rhs_Base, W_Disp, Logical Left) -
                          %else N = Ishift(Rhs_Base, W_Disp, Logical Right)
         %else
            Loadup(W)
            %if Op = LSHx %then N = Rshift(Rhs_Base, W_Base, Logical Left R) -
                          %else N = Rshift(Rhs_Base, W_Base, Logical Right R)
         %finish
         Plant1(Easy Op(NewOper), Lhs_Base, Lhs_Base, N)
         Release and Drop Pair(Rhs, W)
         %return
      %else
         Loadup(Rhs)
      %finish
   %finish

   %if Iconst(Rhs) %start
      Rconst = 1
      %if NewOper = SUBX %start                    { Lhs-(+const) }
         %if Rhs_Disp # Minus Infinity %start
            Rhs_Disp = -Rhs_Disp
            NewOper = ADDx                            { Lhs+(-const) }
            Rflags = Oper Flags(ADDx)
         %finish
      %finish
      %if Oper Flags(NewOper)&Nullop # 0 %and Null Value(NewOper) = Rhs_Disp %start
         Drop(Rhs)
         %return
      %finish
   %else
      Rconst = 0
   %finish

   %if Lhs_Oper # 0 %start
      Op = Lhs_Oper;  Lflags = Oper Flags(Op)
      W == Lhs_Link
      %if Op = NEGx %and NewOper = MULx %start
         Lhs_Oper = 0
         Operate(MULx, Lhs, Rhs)
         Operate(NEGx, Lhs, Nil)
         %return
      %finish
      %if Lflags&Unary = 0 %and Iconst(W) %start
         %if Rconst # 0 %and NewOper < RNEGx %start
            Key = (Lflags!Rflags)&Assoc Mask
            %if Key = 0          {strongly associative} %or -
               (Key = Weak Assoc {weakly associative}   %and NewOper = Op) %start
               %if Rhs_Base = None %or NewOper = ADDX %start
                  Constant Operation(NewOper, W_Disp, Rhs)
                  Reduce Constant %if Rhs_Base = None
                  ->Mon
               %finish
            %finish
            %if Op = LSHx %and NewOper = ANDx %and -31 <= W_Disp <= 0 %start
               N = Field(Rhs_Disp, -W_Disp, 0)
               %if N # 0 %start
                  Zap %and ->Mon %if N = -1
                  W_Disp = N;  Lhs_Oper = EXTx
                  Drop(Rhs)
                  ->Mon
               %finish
            %finish
            %if Op = ANDx %and NewOper = RSHx %and 0 <= Rhs_Disp <= 31 %start
               N = Field(W_Disp, Rhs_Disp, 1)
               %if N # 0 %start
                  Zap %and ->Mon %if N = -1
                  W_Disp = N
                  Lhs_Oper = EXTx
                  Drop(Rhs)
                  ->Mon
               %finish
            %finish
!!            %if Op = ADDx %and NewOper = MULx %start     { (A+c)*m -> Am+cm }
!!               W_Disp = W_Disp*Rhs_Disp
!!               Lhs_Link == Nil;  Lhs_Oper = 0
!!               Operate(MULx, Lhs, Rhs)
!!               Operate(ADDx, Lhs, W)
!!               %return
!!            %finish
         %finish
      %finish
      %if (Op = LSHx %or Op = RSHx) %and Oper Flags(NewOper)&Easy # 0 -
                                    %and NewOper # BICx               -
                                    %and Rhs_Type < Reals %start
         Lhs_Link == NIL;  Lhs_Oper = 0
         Loadup(Lhs)
         Loadup(Rhs)
         %if Iconst(W) %start
            %if Op = LSHx %then N = Ishift(Lhs_Base, W_Disp, Logical Left) -
                          %else N = Ishift(Lhs_Base, W_Disp, Logical Right)
         %else
            Loadup(W)
            %if Op = LSHx %then N =Rshift(Lhs_Base, W_Base, Logical LeftR) -
                          %else N =Rshift(Lhs_Base, W_Base, Logical RightR)
         %finish
         Fn = Easy Op(NewOper)
         Fn = RSB %if NewOper = SUBx     {not commutative}
         Plant1(Fn, Rhs_Base, Lhs_Base, N)
         Release and Drop Pair(Rhs, W)
         %return
      %finish
      Loadup(Lhs)                           {no other choice}
   %finish

   %if Iconst(Lhs) %and Rconst # 0 %and NewOper < RNEGx %start
      Constant Operation(NewOper, Lhs_Disp, Rhs)
      ->Mon
   %finish

   %if Lhs_Type >= Reals %or Rhs_Type >= Reals %start
      NewOper = NewOper+Real Shift %unless NewOper >= RNEGx
      %if Lhs_Type = Sets %start
         %if Lhs_Flags = Null Set %start
            Swop %if NewOper = RADDx               {keep the other set}
            Rhs_Type = 0
         %else %if Rhs_Flags = Null Set
            Swop %if NewOper = RMULx               {keep the null set}
            Rhs_Type = 0
         %finish
         Lhs_Oper = NewOper;  Lhs_Link == Rhs
         %if Rhs_Type = 0 %start
            Lhs_Oper = 0;  Lhs_Link == Nil
            Drop Members(Rhs);  Release and Drop(Rhs)
         %finish
         ->Mon
      %finish
   %finish

   %if Rflags&Commutative # 0 %and InReg(Rhs) %start
      Swop
      Rconst = 0
      Rconst = 1 %if Iconst(Rhs)
   %finish
   %if NewOper = SUBx %and Lhs_Form  = Address = Rhs_Form %start
      {try to optimise addr(x) - addr(y)}
      %if Lhs_Base = Rhs_Base %and Lhs_Area = Rhs_Area %start
         %if Same(Lhs_Index, Rhs_Index) %and Same(Lhs_Record, Rhs_Record) -
                                        %and Lhs_Xsize = Rhs_Xsize %start
            Lhs_Disp = Lhs_Disp - Rhs_Disp
            Release and Drop(Rhs)
            Release and Drop(Lhs_Index) %if Lhs_Index ## Nil
            Release and Drop(Lhs_Record) %if Lhs_Record ## Nil
            Lhs_Base  = 0
            Lhs_Xsize = 0
            ->Mon
         %finish
      %finish
   %finish
   Lhs_Oper = NewOper;  Lhs_Link == Rhs
   Reduce Constant %if Rconst # 0
Mon:
   Monitor(Lhs, "<-Operate") %if Diag&MonOperate # 0
%end

%routine Aop
   %integer Type, Format, Size
   %record(Stackfm)%name X
   X     == Stack                               {index value}
   Stack == X_Stack                             {the base item}
   Size = Item Size(Stack_Format)
   %if Stack_Index == Nil %start
      Stack_Index == X;  Stack_Xsize = Size
   %else %if Stack_Xsize = Size
      Operate(ADDx, Stack_Index, X)
   %else
      Type   = Stack_Type;  Format = Stack_Format
      Amap(Stack)
      Operate(MULx, X, Literal(Size))
      Operate(ADDx, Stack, X)
      Vmap(Stack, Type);  Stack_Format = Format
   %finish
%end

%routine Operation(%integer Oper)
   %record(Stackfm)%name V
   V     == Stack
   Stack == Stack_Stack
   Operate(Oper, Stack, V)
%end

%routine Replace(%record(Stackfm)%name Old, New)
   Zap Index and Record(Old)
   Release(Old_Base)
   Old_Base   = New_Base
   Old_Disp   = New_Disp
   Old_Extra  = New_Extra
   Old_Type   = New_Type
   Old_Form   = New_Form
   Old_Format = New_Format
   Old_Area   = New_Area
   Old_Oper   = 0
   Old_Link  == Nil
   Drop(New)
%end

{***Register optimisation routines***}

%predicate Memorable(%record(Stackfm)%name V, %record(Knowfm)%name K)
   %integer Op = 0, Scale = 0
   %if V_Oper # 0 %start
      %false %unless V_Link ## Nil %and Iconst(V_Link)
      Op    = V_Oper
      Scale = V_Link_Disp
   %finish
   %false %if V_Index ## Nil %or V_Record ## Nil %or V_Form >= Memorable Limit
   K_Ftype = V_Type<<4+V_Form
   K_Base  = V_Base
   K_Disp  = V_Disp
   K_Extra = V_Extra
   K_Area  = V_Area
   K_Opnd  = Scale
   K_Oper  = Op
   K_Ftype = Integers<<4 + Address %if Iconst(V)
   %true
%end

%routine Optimise(%record(Stackfm)%name V, %integer Swanted)
   {Swanted = 0 if destination (address) wanted}
   {        = 1 if source (value) wanted}
   %record(Knowfm)%name P
   %record(Knowfm) M
   %record(Stackfm)%name W
   %integer Op


   P == Knowing;  %return %if P == Nil        {nothing known}

   %if V_Oper # 0 %start
      Op = V_Oper;  V_Oper = 0
      W == V_Link;  V_Link == Nil
      Optimise(V, 1)
      Optimise(W, 1) %unless W == Nil
      V_Oper = Op;  V_Link == W
   %finish

   %if V_Record ## Nil %start
      Optimise(V_Record, 1)
      %if V_Record_Form = Address %start
         Simplify(V)
         P == Knowing;  %return %if P == Nil        {nothing known}
      %finish
   %finish
   %return %unless Memorable(V, M)             {worth looking for?}
   Monitor(V, "Opt") %if Diag&MonOpt # 0

      %routine Set(%integer Form)
         %if V_Oper # 0 %start
            Release and Drop(V_Link)
            V_Oper = 0;  V_Link == Nil
         %finish
         V_Type = Integers %if Form = Address %and V_Type <= Addrs  {already expanded}
         V_Form = Form
         Release(V_Base)
         V_Area = 0
         V_Disp = 0;  V_Base = P_Reg
         Pending Auto = 0 %if P_Reg = Pending Auto
         Claim(V_Base)
         Monitor(V, "Opt->") %if Diag&MonOpt # 0
      %end

   %cycle
      %if P_Disp  = M_Disp  %and P_Area = M_Area %and
          P_Extra = M_Extra %and P_Oper = M_Oper %and
          P_Base  = M_Base  %and P_Opnd = M_Opnd %start  {Basically ok}
         %if P_Ftype = M_Ftype %and Swanted # 0 %start   {exact match}
            Set(Address)
            %return
         %else %if M_Oper = 0 %and M_Ftype&15 # Address  {beware real zero}
            %if P_Ftype = Integers<<4+Address %start     {we have the address}
               Set(V_Form)
               Optimise(V, 1) %if Swanted # 0
               %return
            %finish
         %finish
      %finish
      P == P_Link
   %repeat %until P == Nil
%end

%record(Knowfm)%map NewK
   %record(Knowfm)%name P
   P == Kasl
   %if P == Nil %start
      P == NEW(KnowfmType);  P = 0
   %else
      Kasl == P_Link
   %finish
   %result == P
%end

%routine Kinc(%record(Knowfm)%name K)
   Ktimes(K_Reg)  = Ktimes(K_Reg)+1
   Ktimes(K_Base) = Ktimes(K_Base)+1 %if K_Base&128 = 0 {beware base registers}
%end

%routine Kdec(%record(Knowfm)%name K)
   Ktimes(K_Reg)  = Ktimes(K_Reg)-1
   Ktimes(K_Base) = Ktimes(K_Base)-1 %if K_Base&128 = 0 {beware base registers}
%end

%routine Forget(%integer Register)
   %integername N
   %record(Knowfm)%name K, R
   %return %unless R0 <= Register <= F7
   Pending Auto = 0 %if Pending Auto = Register
   N == Ktimes(Register)
   Used(Register) = 0
   %return %if N = 0 {%or Activity(Register) < 0}    {004}
   K == Knowing;  Knowing == Nil
   %while K ## Nil %cycle
      R == K;  K == K_Link
      %if R_Reg = Register %or R_Base = Register %start
         R_Link == Kasl;  Kasl == R
         Kdec(R)
         Mon Regid(R_Reg, "Forgotten") %if Diag&MonOpt # 0
      %else
         R_Link == Knowing;  Knowing == R      {retain it}
      %finish
   %repeat
   Fail("Register still known") %if N # 0
%end

%routine Forget Everything
   %record(Knowfm)%name K
   Pending Auto = 0
   K == Knowing
   %if K ## Nil %start
      %cycle
         Used(K_Reg)  = 0
         Used(K_Base) = 0 %if K_Base&128 = 0    {beware of level bases}
         Kdec(K)
         %exit %if K_Link == Nil
         K == K_Link
      %repeat
      K_Link == Kasl;  Kasl == Knowing
      Knowing == NIL
   %finish
%end

%routine Inherit(%integer New, Old)
   %record(Knowfm)%name P, K, X
   %return %if New = Old
   Used(New) = Used Time
   P == Knowing
   %while P ## Nil %cycle
      K == P;  P == K_Link
      %if K_Reg = Old %start
         Mon Regid(Old, "inherited") %if Diag&MonOpt # 0
         X == NewK;  %return %if X == Nil
         X = K
         X_Reg  = New
         X_Link == Knowing;  Knowing == X
         Kinc(X)
      %finish
   %repeat
%end

%routine Remember(%integer Register, %record(Stackfm)%name V)
   %record(Knowfm)%name K
   %record(Knowfm) M
   %return %unless R0 <= Register <= F7 %and Register # Any
   Used(Register) = Used Time
   %if InReg(V) %start             {inherit other register's data}
      Inherit(Register, V_Base)
      %return
   %finish
   %return %if Register = V_Base
   %if Memorable(V, M) %start
      K == NewK;  %return %if K == Nil
      K = M
      K_Reg = Register
      K_Link == Knowing;  Knowing == K
      Kinc(K)
      Monitor(V, "Remember ".Regid(Register)) %if Diag&MonOpt # 0
   %finish
%end

%routine Remember Zero(%integer Register)
   %record(Stackfm)%name Zero == Literal(0)
   Forget(Register)
   Remember(Register, Zero)
   Drop(Zero)
%end

%routine Forget Destination(%record(Stackfm)%name V)
   %integer Low, High, Base = V_Base, Unsafe = 0, Alter
   %record(Knowfm)%name P, K
   Monitor(V, "Forget Dest") %if Diag&MonOpt # 0
   Forget(V_Base) %and %return %if InReg(V)
   Low = V_Disp;  High = Low+Item Size(V_Format)-1
                  High = Low+3 %if High < Low
   P == Knowing;  Knowing == Nil

   !
   !  If generated a instruction of form STR _ Rx, y(Rz) then
   !  should forget registers that hold non-address values.
   !  Do not do this if trusted => trusted gets some progs wrong
   !

   %if Interface_Options & LL Trusted = 0 %start
      %if V_Base < 128 %and Activity(V_Base) >= 0 %start
         Unsafe = 1
      %else %if V_Index ## Nil 
         Unsafe = 1
      %finish
      Monitor N(Unsafe, "Unsafe") %if Diag&MonOpt # 0
   %finish

   %while P ## Nil %cycle
      K == P;  P == P_Link
      Alter = 0

      Alter = Unsafe %if K_Base < 128 %and Activity(K_Base) >= 0

      %if K_Ftype&15 # Address %start  {can remember addresses}
         Alter = 1 %if K_Base = Base %and Low <= K_Disp <= High
      %finish

      %if Alter # 0 %start
         Kdec(K)
         K_Link == Kasl;  Kasl == K
         Mon Regid(K_Reg, "Altered") %if Diag&MonOpt # 0
      %else
         K_Link == Knowing;  Knowing == K  {remember it}
      %finish
   %repeat
%end

{Environment handling}

%routine Forget Environment(%integer Label)
   %record(Labelfm)%name L
   %record(Knowfm)%name P, E
   L == Ilabel(Label)
   P == L_Env;  L_Env == NIL
   %if P ## NIL %start
      E == P
      P == P_Link %while P_Link ## NIL
      P_Link == Kasl
      Kasl == E
   %finish
%end

%routine Remember Environment(%integer Label)
   %record(Knowfm)%name K, Top == NIL, P
   Forget Environment(Label)
   K == Knowing
   %while K ## Nil %cycle
      P == NewK              {cannot return Nil}
      P = K
      P_Link == Top
      Top == P
      Mon RegId(P_Reg, "in env") %if Diag&MonOpt # 0
      K == K_Link               {onto the next item}
   %repeat
   Ilabel(Label)_Env == Top     {remember the start}
%end

%routine Merge Environment(%integer Label)
   {Update the saved environment of Label with the data in Knowing}
   {Knowing is unaltered}
   %record(Labelfm)%name L
   %record(Knowfm)%name P, K, Next, Top
   Monitor(Nil, "merge") %if Diag&MonOpt # 0
   %if Knowing == Nil %start
      Forget Environment(Label)
   %else
      L == Ilabel(Label)
      Top == Nil
      Next == L_Env
      %cycle
         P == Next;  %exit %if P == Nil
         Next == P_Link
         K == Knowing
         %cycle
            %if K_Reg   = P_Reg   %and                       %c
                K_Disp  = P_Disp  %and K_Base = P_Base  %and %c
                K_Ftype = P_Ftype %and K_Area = P_Area  %and %c
                K_Opnd  = P_Opnd  %and K_Oper = P_Oper  %start
               P_Link == Top;  Top == P
               Mon RegId(P_Reg, "Merged") %if Diag&MonOpt # 0
               ->Found
            %finish
            K == K_Link
         %repeat %until K == Nil
         {Not Found}
         P_Link == Kasl;  Kasl == P      {return the cell}
Found:%repeat
      L_Env == Top
   %finish
%end

%routine Restore Environment(%integer Label)
   %record(Knowfm)%name P, K, Next
   Forget Everything              {dispose of old knowledge}
   Next == Ilabel(Label)_Env
   %cycle
      P == Next;  %return %if P == NIL
      Next == P_Link
      K == NewK
      K = P
      K_Link == Knowing;  Knowing == K
      Kinc(K)
      Mon RegId(P_Reg, "back") %if Diag&MonOpt # 0
   %repeat
%end

{Register Control}

%routine Claim(%integer Register)
   %return %unless R0 <= Register <= AnyF %and Activity(Register) >= 0
   Activity(Register) = Activity(Register)+1
   Active Registers = Active Registers+1
   Used Time = Used Time+1;  Used(Register) = Used Time
   Monitor Register(Register, "Claimed") %if Diag&MonReg # 0
%end

%routine Release(%integer Register)
   %return %unless R0 <= Register <= AnyF %and Activity(Register) >= 0
   Activity(Register) = Activity(Register)-1
   Fail("Register not claimed") %if Activity(Register) < 0
   Monitor Register(Register, "Released") %if Diag&MonReg # 0
   Active Registers = Active Registers-1
   Fail("Register unclaimed") %if Active Registers < 0
%end

%routine To Store(%integer Code)
   %if Code # 0 %start
      %if Code = 3 %start     {short}
         Loadup(Stack) %if Stack_Type = Bytes
      %else %if Code = 1      {integer}
         Loadup(Stack) %if Stack_Type = Bytes %or Stack_Type = Shorts
      %finish
   %finish
   %if Stack_Form = Address %or Stack_Oper # 0 %or Stack_Index ## Nil %start
      %if Stack_Type = Strings %or Stack_Type = Records %start
         Evaluate String Expression(Stack)       {is this ok for records?}
      %else
         Loadup(Stack)
         Hazard(Stack_Base)
      %finish
   %finish
%end

%routine Pessimise(%record(Stackfm)%name V)
   {this routine forces V into store - either by de-optimising it}
   {or simply by storing it}
   %integer Reg, N, Disp
   %record(Knowfm)%name K
   %record(Stackfm)%name T
   Monitor(V, "Pessimise->") %if Diag&MonOperand # 0
   Fail("Not loaded") %unless Inreg(V)
   Reg = V_Base
   N = Ktimes(Reg)
   K == Knowing;  K == NIL %if N = 0
   %cycle
      %if K == NIL %start                                  {not known in store}
         Fail("corrupt knowing") %if N # 0
         Reg = V_Base                                      {Must store it}
         %if R0 <= Reg <= R15 %start                       {integer}
            T == Claim Work Area(Word Length, Integers)
         %else                                             {floating}
            T == Claim Work Area(2*Word Length, Lreals)
         %finish
         Disp = T_Disp     {in case SIMPLE corrupts it}
         Simple(V, T)
         Release(Reg)
         V_Base = Local;  V_Disp = Disp;  V_Form = Direct
         Drop(T)
         %exit
      %finish
      %if K_Reg = Reg %start
         N = N-1
         %if K_Oper = 0 = K_Opnd %start
            %if K_Ftype = V_Type<<4 + Direct %and K_Area = V_Area -
                                             %and Locked(K_Base) %start
               Release(Reg)
               V_Base = K_Base
               V_Disp = K_Disp
               V_Extra = K_Extra
               V_Form = Direct
               V_Flags = Known Ass
               Claim(V_Base)
               %exit
            %else %if K_Ftype = Integers<<4 + Address %and K_Base = 0 -
                                                      %and K_Area = 0  {constant}
               Release(Reg)
               V_Base = 0;  V_Disp = K_Disp
               V_Form = Address
               V_Area = 0
               V_Flags = Known Ass
               %exit
            %finish
         %finish
      %else %if K_Base = Reg
         N = N-1
      %finish
      K == K_Link
   %repeat
   Monitor(V, "Pessimise<-") %if Diag&MonOperand # 0
%end

%routine Hazard(%integer Reg)
   %integer Register = |Reg|
   {This unpleasant routine has to deal with the horrors of needing}
   {a register and so needing to ensure that it does not hold}
   {useful data already.}
   {***perhaps improve use of PESSIMISE***}
   %record(Stackfm)%name U, R
   %integername N
   %integer Disp, Stored = 0

   %routine Store
      %record(Stackfm)%name T
      %return %if Stored # 0
      Stored = 1
      %if R0 <= Register <= R15 %start                  {integer}
         T == Claim Work Area(Word Length, Integers)
      %else                                             {floating}
         T == Claim Work Area(2*Word Length, Lreals)
      %finish
      Disp = T_Disp
      Simple(RegV(Register), T);  Release and Drop(T)
   %end

   Monitor Register(Register, "Hazard") %if Diag&MonReg # 0

   N == Activity(Register);  %return %if N <= 0      {locked/free}
   U == Using
   %while U ## Nil %cycle
      %if U_Base = Register %start             {the index looks after itself}
         Monitor(U, "Hazarding") %if Diag&MonReg # 0
         %if N = 1 %and Stored = 0 %and InReg(U) %start
            Pessimise(U)
            %return
         %finish
         Store
         %if U_Form = Address %and U_Disp = 0 %and U_Index == Nil %start   {it's a regster}
            U_Form = Direct;  U_Base = Local;  U_Disp = Disp
         %else                                         {make it look like a record}
            Fail("Corrupt record") %if U_Record ## Nil
            R == Local Integer(Disp)
            R_Flags = Hazarded
            U_Base = None;  U_Record == R
         %finish
         Release(Register)
      %finish
      U == U_Using
   %repeat

   %if N # 0 %start
      Fail("Use lost") %if N # 0
   %finish
%end

%routine Hazard All
   Hazard(R0);  Hazard(R1);  Hazard(R2);  Hazard(R3)
   %return %if Active Registers = 0
   Hazard(R4);  Hazard(R5);  Hazard(R6);  Hazard(R7)
   %return %if Active Registers = 0
   Hazard(R8);  Hazard(R11);  Hazard(R14)
   %return %if Active Registers = 0
   Hazard(F0);  Hazard(F1);  Hazard(F2);  Hazard(F3)
   %return %if Active Registers = 0
   Hazard(F4);  Hazard(F5);  Hazard(F6);  Hazard(F7)
%end

{Descriptor Control}

%record(Stackfm)%map Descriptor
   %record(Stackfm)%name V
   %if Dasl == Nil %start                   {empty, grab some from the heap}
      Dasl == NEW(Stackfm Type)
      Dasl_Using == Nil
   %finish
   V == Dasl;  Dasl == V_Using
   V = 0
   V_Using == Using;  Using == V
   %result == V
%end

%routine Drop All(%record(Stackfm)%name V)
   Drop All(V_Index)  %and V_Index  == Nil %if V_Index  ## Nil
   Drop All(V_Record) %and V_Record == Nil %if V_Record ## Nil
   Drop(V)
%end

%routine Drop(%record(Stackfm)%name V)
   %record(Stackfm)%name P, E
   Monitor(V, "Drop") %if Diag&MonStack # 0
   Zap Index and Record(V)
   %if Using == V %start                  {first is quick}
      Using == V_Using
   %else                                  {otherwise search for it}
      P == Using
      %cycle
         Fail("Not in use") %if P == Nil
         E == P
         P == P_Using
      %repeat %until P == V
      E_Using == P_Using
   %finish
   V_Using == Dasl;  Dasl == V
%end

%routine Release and Drop(%record(Stackfm)%name V)
   Release and Drop(V_Link) %unless V_Link == Nil
   Release(V_Base)
   Drop(V)
%end

%routine Zap Index and Record(%record(Stackfm)%name V)
   Release and Drop(V_Index ) %and V_Index  == Nil %unless V_Index  == Nil
   Release and Drop(V_Record) %and V_Record == Nil %unless V_Record == Nil
%end

%routine Release and Drop Pair(%record(Stackfm)%name A, B)
   Release and Drop(A)
   Release and Drop(B)
%end

%routine Pop Release and Drop
   %record(Stackfm)%name S
   S == Stack
   Stack == S_Stack
   Release and Drop(S)
%end

%routine Drop Members(%record(Stackfm)%name S)
   %record(Memberfm)%name M, X
   M == S_Members ; S_Members == Nil
   %while M ## Nil %cycle
      X == M ; M == M_Link
      %if X_Const # 0 %start
         Drop(X_A)
         Drop(X_B) %if X_B ## Nil
      %else
         Release and Drop(X_A)
         Release and Drop(X_B) %if X_B ## Nil
      %finish
      Dispose(X)
   %repeat
%end

%routine Apply Indirection   {to the stack}
   %record(Stackfm)%name W
   W == Stack;  Stack == Descriptor
   Stack_Stack == W_Stack
   Stack_Type = W_Type;    Stack_Form = Direct;  Stack_Record == W
   Stack_Format = W_Format
   W_Type = Integers;  W_Form = Direct;  W_Format = 0
%end

%routine Stack True or False(%integer CC)
   {CC is the condition for TRUE}
   %integer Other, R, Lab
   %record(Stackfm)%name V
   V == Literal(0);  Optimise(V, 1)     {try for zero=false}
   %if InReg(V) %start                  {Yes}
      CC = Negated(CC)
      Other = 1
   %else                                {No, try for one=true}
      V_Disp = 1;  Other = 0
   %finish
   Load Protected(V);  R = V_Base       {in case the register is in use}
   Release and Drop(V)
   Fail("register active") %unless Activity(R) = 0
   Lab = New Label
   Jump To(Lab, CC);  V == Literal(Other);  Load(V, R);  Define Label(Lab)
   Forget(R)
   V_Stack == Stack;  Stack == V
%end

%routine Stack Var(%integer Varno)
   %integer Form, Flags
   %record(Stackfm)%name V
   V == Descriptor
   V_V = Var(Varno)
   V_Varno = Varno
   V_Stack == Stack
   Stack == V
   Attributes = Attributes ! Attr Needs Gp %if Stack_Base = SB
   Form = V_Form
   %if V_Flags&XData Spec # 0 %start
      Flags = V_Flags;  V_Flags = 0
      Apply Indirection
      Stack_Flags = Flags&(\XData Spec)
   %finish
   Apply Indirection %if Form = Indirect       {Be careful to use original}
   Monitor(Stack, "Stack Var") %if Diag&MonStack # 0
%end

%record(Stackfm)%map Local Integer(%integer Disp)
   %record(Stackfm)%name V
   V == Descriptor
   V_Type  = Integers;  V_Form = Direct
   V_Base  = Local;     V_Disp  = Disp
   V_Flags = Known Ass
   %result == V
%end

%record(Stackfm)%map Literal(%integer N)
   %record(Stackfm)%name V
   V == Descriptor
   V_Disp = N
   V_Type = Integers
   V_Flags = Known Ass               {ready for form being changed to direct}
   %result == V
%end

%routine Stack Integer(%integer N)
   %record(Stackfm)%name V
   V == Literal(N)
   V_Stack == Stack
   Stack == V
%end

%integerfn Popped Value
   %record(Stackfm)%name V
   V == Stack
   Stack == V_Stack
   Drop(V)
   %result = V_Disp
%end

%record(Stackfm)%map Temporary
   {Cannot use CLAIM WORK AREA as they get released at the end of EACH statement}
   %record(Stackfm)%name V
   Frame = Frame&Alignment Mask - Word Length
   V == Local Integer(Frame)
   %result == V
%end

%record(Stackfm)%map Copy(%record(Stackfm)%name V)
   %record(Stackfm)%name C
   %result == Nil %if V == Nil
   C == Descriptor
   C_Data = V_Data;  Claim(C_Base)
   C_Oper = V_Oper
   C_Index  == Copy(V_Index)  %unless V_Index  == Nil
   C_Record == Copy(V_Record) %unless V_Record == Nil
   C_Link   == Copy(V_Link)   %unless V_Link   == Nil
   %result == C
%end

{Stack control}

%routine Select(%integer Item)
   %record(Stackfm)%name V, X
   %record(Varfm)%name Field
   V == Stack
   Field == Var(Var(-V_Format)_Extra-Item)
   Fail("Select") %if V_Form = Address
   Stack_Varno = 0
   {temp frig for  A(4)_Sn == S}
   %if V_Form = Direct %and V_Index == Nil %start
      V_Disp   = V_Disp+Field_Disp
      V_Type   = Field_Type
      V_Form   = Field_Form
      V_Format = Field_Format
      V_Flags  = Field_Flags
      V_Adata == Field_Adata
   %else   {Indirect}
      Amap(V)                               {ready for REDUCE}
      X == Descriptor
      X_V = Field;  X_Base = 0
      X_Record == V
      Stack == X;  X_Stack == V_Stack   {re-link it}
   %finish
   Apply Indirection %if Stack_Form = Indirect
   Monitor(Stack, "Select") %if Diag&MonStack # 0
%end

{Label & Jump Handling}

%routine X Call(%integer Ep, Stackit, Hazard)
   %record(Stackfm)%name V
   Hazard All %if Hazard > 0 %and Active Registers # 0
   Dir2(Dir Xcall, Ep);  Refs = Refs+1;  Ca = Ca+4
   Forget Everything %unless Hazard < 0
   Attributes = Attributes!Attr Needs Gp
   %if Stackit # 0 %start
      Attributes = Attributes!Attr Dynamic
      V == Register(Stackit)
      V_Stack == Stack;  Stack == V
   %finish
%end

%routine Check Compiler Label(%integer Label)
   Fail("compiler labels/1") %if Label > Max Label
%end

%integerfn New Label
   Free Label = Free Label+1
   Fail("too many internal labels") %if Free Label&16_8000 # 0
   %result = Free Label
%end

%routine Jump to(%integer Internal Label, Cond Code)
   Jlab = Internal Label                        {remember for Events}
   Cond Code = Reverse(Cond Code) %and Invert = 0 %if Invert # 0
   Dir3(Dir Branch, Internal Label, Cond Code+Unsigned);  Unsigned = 0
   Refs = Refs+1
   Ca = Ca+4                                    {assume 2 bytes worth}
   Uncond Jump = Ca %if Cond Code = Always      {can't get past here}
   Assign Lock = 0                              {no longer safe}
%end

%routine Define Label(%integer Internal Label)
   Dir2(Dir Label, Internal Label)
   Uncond Jump = -1                             {can get here now}
   Assign Lock = 0                              {can no-longer remember ass}
%end

%routine Define Compiler Label(%integer Label)
   %record(Labelfm)%name L
   Check Compiler Label(Label)
   L == Ilabel(Label)
   %if L_Lab&Defined # 0 %start                     {redefinition}
      Forget Environment(Label)
      L_Lab = New Label
   %finish
   L_Lab = L_Lab!Defined                           {show it's defined}
   Merge Environment(Label) %if Uncond Jump # Ca
   Define Label(L_Lab&Label Mask)
   Restore Environment(Label)
%end

%integerfn Forward Label(%integer Label)
   %record(Labelfm)%name L
   L == Ilabel(Label)
   %if L_Lab&Defined # 0 %start                     {redefine it}
      L_Lab = New Label
      Remember Environment(Label)
   %else                               {another reference}
      Merge Environment(Label)
   %finish
   %result = L_Lab
%end

%routine Jump Forward(%integer Label, Cond Code)
   Check Compiler Label(Label)
   Jump To(Forward Label(Label), Cond Code)
   %if Cond Code = NE %and Pending Known Register # 0 %start
      Remember(Pending Known Register, Pending Known)
   %finish
   Pending Known Register = 0
%end

%routine Jump Backward(%integer Label)
   %record(Stackfm) C, F
   %record(Stackfm)%name U, CC
   %record(Forfm)%name For == Nil
   %record(Varfm)%name Vr
   %record(Labelfm)%name L
   %integer How
   Check Compiler Label(Label)
   L == Ilabel(Label)
   How = Always
   Fail("Label missing") %if L_Lab&Defined = 0
   %if Fors ## Nil %and Label = Fors_Label %start  {repeat of a %for stat}
      For == Fors;  Fors == Fors_Link              {unchain this item}
      C_Data = For_Control
      Vmap(C, For_Type)
      Load(C, For_Reg)
      Define Compiler Label(For_Entry) %if For_Entry # 0
      F_Data = For_Final
      Compare(C, F);  Release(C_Base);  Release(F_Base)
      How = For_CC
   %finish
   Jump To(L_Lab&Label Mask, How)
   %if For ## Nil %start
         %if How # Always %and Language Flags&Undefined Control # 0 -
                       %and Unassigned # 0 %start
         CC == Literal(0)
         CC_Data = For_Control
         Vmap(CC, For_Type)
         U == Copy(UaPat);  U_Type = For_Type
         Simple(U, CC)            {Zap the control variable}
         Forget Destination(CC)   {PSR 02NOV87}
         Forget(U_Base)           {beware of remembering bytes with zero}
         Release and Drop(U)
         Release and Drop(CC)
         %if For_Control_Varno # 0 %start
            Vr == Var(For_Control_Varno)
            Vr_Flags = Vr_Flags&(\Known Ass)
         %finish
      %finish
      Dispose(For)
   %finish
%end

%routine Set User Label(%integer Label)
   %record(Varfm)%name V
   V == Var(Label)
   Clear Vars(Label)
   V_Type = Labels
   V_Base = Local
   V_Disp = New Label
%end

%routine User Jump(%integer Label)
   %owninteger Jout = 0
   %integer B
   %record(Stackfm)%name Base
   %record(Varfm)%name V
   %record(Varfm) C
   V == Var(Label)
   Set User Label(Label) %if Label > Vars %or V_Disp = 0       {Not in Yet allocated a var}
   B = V_Base
   %if B # Local %start                                        {non-local}
      Base == Display Info(B)
      Release and Drop(Base)
      Base == Literal(0);  Base_Base = B;  Base_Flags = Known Ass
      Load(Base, Fp)                              {Restore old Fp}
      Base_Disp = V_Extra;  Base_Form = Direct;  Base_Flags = Known Ass
      Load(Base, R3);  Release and Drop(Base)     {new value for SP}
      Do("3L_pascal___jump_out", Jout, 0)
   %finish
   Jump To(V_Disp, Always)
%end

%routine Mark User Label
   Dir1(Dir Mark User)
%end

%routine Define User Label(%integer Label)
   %record(Varfm)%name V
   V == Var(Label)
   Set User Label(Label) %if Label > Vars %or V_Disp = 0       {Not in Yet allocated a var}
   Define Label(V_Disp)
   Mark User Label
   Forget Everything
%end

   %routine Return(%integer How)
      %integer Result Reg, Type
      %record(Stackfm)%name V, W
      %if Uncond Jump = Ca %start
         Pop Release and Drop %if How < 0                 {remove stacked result}
         %return
      %finish
      V == Nil
      Result Reg = R0
      Type = Avar_Type
      %if How = True %start
         V == Literal(1)
      %else %if How = False
         V == Literal(0)
      %else %if How # 0
         V == Stack;  Stack == Stack_Stack
         %if How = Map %start
            Amap(V)
            Type = Addrs              {map result types are addresses}
         %else %if Type = Strings %or Type = Records
            W == Literal(0)
            W_Type = Type;  W_Form = Direct
            W_Record == Local Integer(String Result)
            W_Record_Format = Avar_Format
            %if W_Type = Strings %then String Assign(V, W) -
                                 %else Record Assign(V, W)
            Release and Drop Pair(W, V)
            V == Nil
         %finish
      %finish
      %if V ## Nil %start
         %if Type = Reals %or Type = Lreals %start
            Load(V, F0)
         %else
            Load(V, Result Reg)
         %finish
         Release and Drop(V)
      %finish
      Dir2(Dir Return, Parameter Frame)
      Refs = Refs+1
      Ca = Ca+4                                    {assume two bytes}
      Uncond Jump = Ca                             {Can't get past here}
      Open = 0                                     {the procedure returns}
   %end

   %routine Stab(%record(Stackfm)%name V)
      %record(Stackfm)%name T, TT
      %return %if Iconst(V)
      T == Temporary;  TT == Copy(T)               {in case of corruption by store}
      Store(V, T)
      Release and Drop(T)
      Replace(V, TT)
      V_Flags = V_Flags!Known Ass
   %end

   %routine Compile For(%integer Repeat Label)
      %integer Type, N
      %record(Stackfm)%name Initial,         {initial value}
                            Final,           {final value}
                            Inc,             {increment}
                            Control,         {control variable}
                            Increment,       {copy of increment}
                            C                {copy of control}

      %record(Forfm)%name For
      %record(Varfm)%name V

      %integerfn Loop Type
         %integer I, N
         %result = 1 %unless Iconst(Initial) %and Iconst(Inc)  -
                                             %and Iconst(Final)
         I = Inc_Disp
         N = Final_Disp-Initial_Disp+I
         %if I # 0 %start
            %result = 1 %if N = 0                   {zero iterations?}
            %if N!!I >= 0 %and Rem(N, I) = 0 %start {constant}
               %if For Range ## Nil %start
                  %unless For Range_Disp <= Initial_Disp <= For Range_Extra %and
                          For Range_Disp <=   Final_Disp <= For Range_Extra %start
                     %result = 1                    {check it dynamically}
                  %finish
                  For Range == Nil                 {all OK}
               %finish
               %result = 0
            %finish
         %finish %else I = 1
         %if Language Flags&Non Exact For = 0 %start
            Warn(1, "Non-integral %for loop")
            Final_Disp = Initial_Disp+N//I*I
         %finish
         %result = 1
      %end

      Final          ==         Stack
      Inc            ==   Final_Stack
      Initial        ==     Inc_Stack
      Control        == Initial_Stack
      Stack          == Control_Stack

      Stab(Inc)
      Type = Control_Type
      %unless Control_Form = Direct  -
         %and Control_Index == NIL   -
         %and Control_Record == NIL  -
         %and  (Control_Base = None  -
            %or Control_Base = Local -
            %or Control_Base = SB)   %start
         {protect expensive (i.e. non-local) or moveable control variable}
         Amap(Control);  Stab(Control)      {save its address}
      %else
         Amap(Control)
      %finish
      Simplify(Control)

      For == NEW(ForfmType);  For_Link == Fors;  Fors == For
      For_Label   = Repeat Label
      For_Control = Control_Data
      Vmap(Control, Type);  For_Type = Type
      For_Entry   = Loop Type               {and check on the fly}
      For_AS      = 0                       {no +1 or -1 yet}

      N = Inc_Disp
      For_CC = NE
      %if Language Flags&Non Exact FOR # 0 %and For_Entry # 0 %start
         %if N = 1 %start
            For_CC = LT
         %else %if N = -1
            For_CC = GT
         %finish %else Fail("corrupt increment")
      %finish
      Increment == Copy(Inc)        {beware of corruption in operate}
      Operate(SUBx, Initial, Inc)
      Loadup(Initial);  For_Reg   = Initial_Base
      Stab(Final);          For_Final = Final_Data
      Load(Initial, For_Reg)                    {beware of HAZARD in STAB}
      %if For_Entry # 0 %start                  {may never execute the loop}
         %if Language Flags&Undefined Control = 0 %start
            {must save the initial value in case the loop isn't executed}
            C == Copy(Control)
            Store(Initial, C)
            Release and Drop(C)
         %finish
         For_Entry = Repeat Label+2
         Jump Forward(For_Entry, Always)
      %finish
      Define Compiler Label(Repeat Label)

      %if For_AS = 0 %start
         Operate(ADDX, Initial, Increment)
         Load(Initial, For_Reg)                {can be removed if desired!}
      %finish
      %if For Range ## Nil %start
         Test Range(Initial, For Range)                {check initial value}
         For Range == Nil
      %finish
      Store(Initial, Control)
      For_Control_V_Flags = For_Control_V_Flags!Known Ass

      %if Control_Varno # 0 %start
         V == Var(Control_Varno)
         V_Flags = V_Flags!Known Ass
      %finish
      Release and Drop Pair(Control, Initial)
      Release and Drop(Final)
   %end

   %record(Stackfm)%map Const String
      %record(Stackfm)%name W
      Constant Base = (Constant Base+3)&(\3)   {align it}
      Select Constant Area
      W == Literal(Ca)
      W_Type = Strings;  W_Form = Direct
      W_Area = Constant Area
      W_Format = Length(Value_String)+1
      W_Bias   = W_Format
      Dump Text(0) %unless Value_String = ""   {I think this is safe?}
      Select Code Area
      %result == W
   %end

   %routine Fix Tostring(%record(Stackfm)%name C)
      %record(Stackfm)%name W
      Value_String = Tostring(C_Disp)
      W == Const String
      C_Data = W_Data
      Drop(W)
   %end

   %routine Set Size or Type(%integer ST, %record(Stackfm)%name V)
      %integer N
      %if V_Type = Generals %start
         Amap(V)
         V_Disp = V_Disp+ST*Word Length              {<addr><size><type>}
      %else
         %if ST = 1 {sizeof} %start
            N = Item Size(V_Format)
            %if N = 1 %and V_Type = Strings %start   {string(*)name}
               Amap(V)
               Advance(V, Integers, Wordlength)
               %return
            %finish
         %else
            N = Type Code(V_Type)
         %finish
         Release(V_Base)
         Zap Index and Record(V)
         V_Data = 0
         V_Disp = N
         V_Type = Integers
         V_Form = Address
      %finish
   %end

   %include "inc.Call"

   %routine Switch Label(%integer Tag)
      Dir2(Dir Slabel, Var(Tag)_Area+Popped Value)
      Uncond Jump = -1
      Assign Lock = 0
      Mark User Label
      Forget Everything
   %end

   %routine Switch Jump(%integer Tag)
      %record(Stackfm)%name X
      X == Stack;  Stack == Stack_Stack            {the index}
      Load(X, R1)
      Release and Drop(X)
      Prim(SwJump)
      Dump Word(16_E792F105)                       {LDR_Pc,[R2,R5 %LSL #2]}
      Dir2(Dir Sw Ref, Var(Tag)_Format);  Ca = Ca+4
      Uncond Jump = Ca
   %end

   %routine Save Wsp
      %record(Stackfm)%name D
      %if Wsp Save = 0 %start
         Frame = (Frame&(\3))-4
         Wsp Save = Frame
      %finish
      D == Local Integer(Wsp Save);  Plant2(STR, Sp, D);  Release and Drop(D)
   %end

   %routine Event Trap(%integer Bits)
            {###################################################}
            {#                    Block(......)                #}
            {#                       ............              #}
            {#                       %on EVENT BITS %start     #}
            {#  Event Label  ->         .......                #}
            {#                          .......                #}
            {#                       %finish                   #}
            {#  Event Body   ->      .......                   #}
            {#                       .......                   #}
            {#                    %end                         #}

            {###################################################}
      %integer Lab
      %record(Stackfm)%name D
      Lab = Tag
      Save Wsp
      Jump Forward(Lab, Always)
      Event Bits  = Bits
      Event Body  = Jlab
      Event Label = New Label
      Define Label(Event Label);  Mark User Label
      Forget Everything
      D == Local Integer(Wsp Save);  Plant2(LDR, Sp ,D);  Release and Drop(D)
      Attributes = Attributes!Attr Dynamic
   %end

%routine Signal Event(%integer Event)
   %record(Stackfm)%name E, Sub Event, Extra
   Extra     == Stack
   Sub Event == Extra_Stack
   Stack     == Sub Event_Stack
   E == Literal(Event)
   Load Trio(E, R1, Sub Event, R2, Extra, R3)
   Release and Drop Pair(E, Sub Event)
   Release and Drop(Extra)
   Prim(Signal)
   Uncond Jump = Ca
   Attributes = Attributes!Attr Dynamic
%end

%include "inc.Compare"

{Assignment}

%routine General Move
   %record(Stackfm)%name F, T, Flen, Tlen
   Flen  == Stack
   Tlen  == Flen_Stack
   F     == Tlen_Stack
   T     == F_Stack
   Stack == T_Stack
   Load Pair(Tlen, R3, Flen, R4)
   Load Pair(T,    R1, F,    R2)
   Load Pair(Tlen, R3, Flen, R4)
   Load Pair(T,    R1, F,    R2)
   Release and Drop Pair(Flen, Tlen)
   Release and Drop Pair(F, T)
   Prim(GenMove)
   Forget Everything
%end

%routine Record Assign(%record(Stackfm)%name From, To)
   %integer LenL, LenR, Inc, Mod, Load, R, Aligned = 1, Zero

   %routine Record Op
      R = GPR %if R < 0
      Plant2(LDR ! Mod, R, From) %if Load # 0
      Plant2(STR ! Mod, R, To)
   %end

   LenL = Item Size(To_Format)
   LenR = Item Size(From_Format)       {note: Var(0)_Format=0 - constants}
   LenL = LenR %if LenL = 0 %or (LenR # 0 %and LenR < LenL)
   %return %if LenL <= 0
   Aligned = 0 %unless LenL&3 = 0 %and Properly Aligned(To, 3)
   Zero = 0
   %if Iconst(From) %start
      Zero = 1
   %else
      Aligned = 0 %unless Properly Aligned(From, 3)
   %finish
   Forget Destination(To)
   Make AutoI(To, Integers)
   Load = 1
   Inc = 4;  Mod = 0                   {assume words}
   %if Aligned = 0 %start              {must use bytes}
      Inc = 1;  Mod = Byte Op
      To_Type = Bytes
   %finish
   %if Zero # 0 %start                 {record = 0}
      Load = 0                         {no load needed}
      Loadup(From)
      R = From_Base
   %else
      Make AutoI(From, To_Type)
      R = -1
   %finish

   Repeat(Record Op, Literal(LenL), Inc, NE)

%end

%routine Set Assign(%record(Stackfm)%name From, Dest)
   %record(Memberfm)%name M, X
   %integer Op = From_Oper, Fn
   %record(Stackfm)%name W, Index
   %record(Stackfm)%name To == Copy(Dest)

   Build Set(From) %if From_Members ## Nil
   W == From_Link
   %if W ## Nil %start
      From_Link == Nil;  From_Oper = 0
      %if From_Flags&Null Set # 0 %start
         From == W
      %else
         Fail("Bad set operator") %if Op # RADDx -
                                 %and Op # RSUBx -
                                 %and Op # RMULx
         %if W_Flags&Null Set = 0 %start
            %unless Same(From, To) %start
               From_Oper = Op;  From_Link == W;  Loadup(From)
               Set Assign(From, To)
               Release and Drop(To)
               %return
            %finish
            Build Set(W) %if W_Members ## NIL %and -
                           (W_Members_Items > 2 %or Op = RMULx)
            Load Address(To, R8)
            %if Op # RMULx %and W_Members ## Nil %start
               M == W_Members;  W_Members == Nil
               %while M ## Nil %cycle
                  X == M;  M == M_Link
                  Load Pair(To, R8, X_A, R1)
                  %if X_B ## Nil %start
                     Load(X_B, R0)
                     Load Pair(To, R8, X_A, R1)
                     Release and Drop(X_B)
                     %if Op = RADDx %then Fn = Set Bits %else Fn = Clear Bits
                  %else %if Op = RADDx
                     Fn = Set Bit
                  %else {%if Op = RSUBx}
                     Fn = ClearBit
                  %finish
                  Release and Drop(X_A);  Dispose(X)
                  Prim(Fn)
               %repeat
               Release and Drop Pair(W, To)
            %else
               Amap(W);  Load Pair(To, R8, W, R11)
               Release and Drop(W)
               %if Op = RADDx %then Fn = Set Add %else -
               %if Op = RSUBx %then Fn = Set Sub       -
                              %else Fn = Set Inter
               Prim(Fn)
               Release and Drop(To)
            %finish
            %return
         %finish
      %finish
   %finish
   Release and Drop(W) %unless W == Nil

   Forget Destination(To)
   %if From_Flags&Null Set # 0 %start
      %routine Zero(%integer R)
         %record(Stackfm)%name W == Literal(0)
         Load(W, R);  Release and Drop(W)
      %end
      Load Address(To, R8)
      Zero(R0);  Zero(R1);  Zero(R2);  Zero(R3)
      Plant4(STM ! IA ! Write Back,   To_Base, 16_000F)
      Plant4(STM ! IA,                To_Base, 16_000F)
   %else
      {Note: if set expressions are about it is likely that the address}
      {      of FROM is in R8, so load R11 first to catch it}
      Load Address(From, R11)
      Load Address(To, R8)
      Hazard(R0);  Hazard(R1);  Hazard(R2);  Hazard(R3)
      Hazard(R4);  Hazard(R5);  Hazard(R6);  Hazard(R7)
      Plant4(LDM ! IA, From_Base, 16_00FF)
      Plant4(STM ! IA,   To_Base, 16_00FF)
      Forget(R0);  Forget(R1);  Forget(R2);  Forget(R3)
      Forget(R4);  Forget(R5);  Forget(R6);  Forget(R7)
   %finish
   Release and Drop(To)
%end

%routine Resolve(%integer Flag)
   {S -> A.(B).C}
   %integer Lab, InLab = 0, Pend, N
   %record(Stackfm)%name S, A, B, C

   N = 0
   %if Flag&1 # 0 %start
      C == Stack;  Stack == Stack_Stack
   %else
      N = N!1
      C == Nil
   %finish
   B == Stack %and Stack == Stack_Stack
   %if Flag&2 # 0 %start
      A == Stack;  Stack == Stack_Stack
   %else
      N = N!2
      A == Nil
   %finish
   S == Stack;  Stack == Stack_Stack

   Evaluate String Expression(B) %if B_Oper # 0
   Fix Tostring(B) %if B_Type <= Addrs
   Amap(S);  Amap(B)
   Load Pair(S, R1, B, R2)
   Release and Drop Pair(S, B)
   Prim(Sres)
   %if Flag&4 = 0 %start                {unconditional}
      Prim(Resflop)
   %else                                {conditional}
      Fail("corrupt resolution") %if Pending # 't' %and Pending # 'k'
      Pend = Pending;  Readsymbol(Pending)
      InLab = Tag
      %if Pend = 't' %start
         Lab = New Label;  Jump to(Lab, NE)
      %else
         Jump Forward(InLab, NE);  InLab = 0
      %finish
   %finish
   Claim(R1);  Claim(R7)   {left fragment}
   Claim(R3);  Claim(R6)   {right fragment}
   %if A ## Nil %start
      Load Address(A, R2);  Prim(Frag1)
      Release and Drop(A)
   %finish
   %if C ## Nil %start
      Load Address(C, R2);  Prim(Frag2)
      Release and Drop(C)
   %finish
   Release(R1);  Release(R7)
   Release(R3);  Release(R6)
   %if InLab # 0 %start
      Jump Forward(InLab, Always)
      Define Label(Lab)
   %finish
%end

%include "inc.Strings"
%include "inc.Store"

%routine Array Index
   %record(Stackfm)%name X, End
   X == Stack                                   {the index}
   Stack == Stack_Stack                         {the array}
   End == Stack
   End == End_Params %while End_Params ## Nil  {find the end}
   End_Params == X
     X_Params == Nil
   Stack_Oper = Stack_Oper+1
%end

%routine Array Access
   %integer N, Lim, Flag, Type, Format, Xsize, Scale Needed = 0, MulOp
   %record(Stackfm)%name X, All, Next, Mult, Scale

   %routine Set up MULT
      Mult == Copy(X_Stack)                  {header}
      Advance(Mult, Integers, 4)             {onto dope vector pointer}
      Loadup(Mult)                       {pick up dope vector}
      Mult_Disp = 20;  Mult_Form = Direct    {select multiplier 0}
   %end

   Scale == NIL
   X == Stack                               {index value}
   Flag = X_Stack_Flags
   MulOp = MULx
   %if Flag&Defered = 0 %start
      Scale Needed = 1 %if (X_Stack_Type = Strings %and X_Stack_Format = 1) -
                       %or (X_Stack_Type = Records %and X_Stack_Format = 0)
   %finish
   Lim = 1
   %if X_Stack_Oper # 0 %start              {final of multi-dimensional}
      Array Index
      Next == Stack_Params
      All == Literal(0)
      Lim = Stack_Oper;  Stack_Oper = 0
      Set up MULT %if Flag&Arrayname # 0    {it's dynamic}
      %for N = 1, 1, Lim %cycle
         X == Next
         Next == X_Params;  X_Params == Nil
         %if N # 1 %start
            %if Flag&Arrayname # 0 %start         {no constant dope vector}
               Operate(MulOp, All, Copy(Mult))
               Mult_Disp = Mult_Disp+12
            %else
               Operate(MulOp, All, Literal(Stack_Adata_Bound(N-1)_Mult))
            %finish
         %finish
         Operate(ADDx, All, X)
      %repeat
      Fail("Corrupt array index") %if Next ## Nil
      X == All
      %if Flag&Array = 0 %start
         %if Scale Needed # 0 %start
            Scale == Mult    {pointing at element size in the dope vector}
         %else
            Release and Drop(Mult)
         %finish
      %finish
   %else                                    {Single dimensional}
      Set up MULT %and Scale == Mult %if Scale Needed # 0
      Stack == X_Stack
   %finish
   Type   = Stack_Type;  Stack_Type = Integers
   Format = Stack_Format
   Vmap(Stack, Integers) %if Flag&Arrayname # 0 {indirect through the header}
   %if Flag&Defered # 0 %start        {namearray}
      Xsize = Wordlength
      Xsize = 2*Wordlength %if Type = Strings %and Format = 1
   %else %if Scale ## NIL
      Operate(MulOp, X, Scale)
      Xsize = 1
   %else
      Xsize = Item Size(Format)
   %finish
   Stack_Flags = Stack_Flags ! Flag
   Apply Index(Stack, X, Xsize)
   %if Flag&Defered # 0 %start        {namearray}
      Vmap(Stack, Type)
   %else
      Stack_Type = Type
   %finish
   Stack_Format = Format
   Stack_Flags = Stack_Flags&( \(Static!Array!Arrayname) )
   Monitor(Stack, "Array") %if Diag&MonOperand # 0
%end

%routine Update Line(%integer This Line)
   Fail("Stack")       %unless Stack == Nil
   Fail("Registers")   %unless Active Registers = 0
   Fail("Descriptors") %unless Using == Nil
   Fail("Corrupt")     %if RegV(Any )_Base # Any -
                       %or RegV(AnyF)_Base # AnyF

   %if This Line # Current Line %start
      Current Line = This Line
      Dir2(Dir Line, Current Line) %if Compiling Prim = 0
   %finish

   %if Diag&MonLine # 0 %start
      Select Output(Report)
      Printstring("Line:");  Write(This Line, 1);  Newline
      Select Output(Directives Out)
   %finish

   Display Knowledge %if Diag&MonOpt # 0
   Work Validity = Work Validity+1      {release work areas}
   Value = Default Value                {restore default values}
   
%end

{Parameter and Format processing}

   %routine Terminate Block
      %integer J, N, M
      %record(Varfm)%name V
      %if Amode < 0 %and Amode # -16 %start      {format - align alternatives}
         Falign = Alt Align            {pass back nested alignment}
         N = 0
         %if Falign = \0 %start        {no alignment needed}
            N = Frame Extra
         %else %if Falign = \1         {halfword alignment}
            N = Frame Extra&2
         %finish
         M = N
         %if N # 0 %start              {can adjust}
            %for J = Parms, 1, First Alt %cycle
               V == Var(J)
               V_Disp = V_Disp-N
            %repeat
            Max Frame = Max Frame-N
            Frame     = Frame-N
         %finish
         Frame = Max Frame %if Max Frame > Frame
         %if Amode = -2 %start                     {end of alternative}
            Old Frame = Frame                      {pass it back}
         %else                                     {end of complete format}
            Avar_Disp = \Falign                    {***align***}
            Frame = (Frame+(\Falign))&Falign
            Avar_Format = Frame
            Dir1(Dir Record Off)
         %finish
      %finish
      Frame = Old Frame
   %end

   %routine Copy Old Display
      %integer T, J

      %routine Copy(%integer Flag, To)
         %record(Stackfm)%name F, T
         F == Literal(0)
         %if Flag < 0 %start
            F_Base = Local;
         %else
            F_Base = R8;  F_Form = AutoI;  Claim(F_Base)
            Loadup(F)
         %finish
         T == Local Integer(To)
         Plant2(STR, F_Base, T)
         Release and Drop Pair(F, T)
      %end

      T = Local Display
      %for J = Danger Level, 1, Local-1 %cycle
         Copy(0, T);  T = T+4
      %repeat
      Copy(-1, T)                  {special for FP}
   %end

   %predicate Finish Params
      %integer J,
               Mod = 0,       {002}
               Type, A, N
      %record(Varfm)%name Ap, Fp, V
      %record(Stackfm)%name S
      Parameter Regs = 0
      Parameter List = 0            {no longer in params or format}
      Flush Diags %and %true %if Amode < 0           {end of format}
      Parameter Frame = Frame

      %if Avar_Flags&Answer # 0 %and Avar_Flags&Defered = 0 %and
                  (Avar_Type = Strings %or Avar_Type = Records) %start
         {allocate a result parameter}
         Parameter Frame = Parameter Frame+4
         String Result = 4;  Mod = Mod+4
      %finish

      %if Amode = 0 %start         {remember parameter registers}
         N = R0
         A = 4
         %while A < Parameter Frame %cycle
            S == Local Integer(A)
            Remember(N, S);  Drop(S)
            Parameter Regs = Parameter Regs+1
            A = A+4
            %exit %if N = R3
            N = N+1
         %repeat
      %finish

      Frame = -20                     {ready for local variables}
      %if Varbase # Vars %start       {parameters given}
         Avar_Extra = Parms           {first-1}
         Avar_Area  = Parameter Frame {size of parameter part of frame}
         %for J = Varbase+1, 1, Vars %cycle
            Ap == Var(J)              {actual}
            Parms = Parms-1
            Fp == Var(Parms)          {formal}
            Ap_Base = Local
            Fp = Ap
            Fp_Base = Sp              {WSP}
            Fp_Form = AutoD
            Fp_Disp = 0;  Ap_Disp = Ap_Disp+Mod
            Fp_Flags = Fp_Flags!Known Ass
            Fp_Flags = Fp_Flags!Awanted %if Ap_Form # Direct
            Fp_Type = Integers %if Fp_Type = Bytes %or Fp_Type = Shorts
            %if Ap_Flags&Awanted # 0 %and Amode = 0 %and Ap_Form # PROC %start
               {string/record value parameter}
               Ap_Flags = Ap_Flags-Awanted
               V == Var(Max Vars);  V = Ap
               Frame = Frame-Item Size(Ap_Format)
               V_Base = Local;  V_Disp = Frame
               Stack Var(Max Vars);  Stack Var(J)
               Type = Stack_Type;  Stack_Type = Integers;  Vmap(Stack, Type)
               Assign(Equals)
               Ap = V
            %finish
            Ap_Flags = Ap_Flags!Known Ass %if Ap_Flags&Parameter = 0
         %repeat
         Flush Diags
      %finish
      %true %if Amode # 0            {not a definition}
      %if Danger Marker # 0 %start
         Danger Level = Local %if Danger Level = No Danger
      %finish
      %if Danger Level # No Danger %start
         Frame = Frame&(\3)-4*(Local-Danger Level+1)
         Local Display = Frame
         Attributes = Attributes ! Attr Local Display ! Attr Inherit
      %finish
      Copy old Display %if Local Display # 0      {copy the display}
      %false                         {the body follows}
   %end

   %integerfn Tag
      %integer N
      Readsymbol(N);  N = Pending<<8+N
      Readsymbol(Pending)
      %result = N
   %end

   %routine Get String(%string(*)%name Text)
      %integer J, Sym, Limit
      Limit = Size of(Text)-1
      Text = ""
      %for J = Pending, -1,1 %cycle
         Readsymbol(Sym)
         Text = Text.Tostring(Sym) %if Length(Text) < Limit
      %repeat
      Readsymbol(Pending)
   %end

   %predicate On IEEE
      {differentiates between VAX & IEEE by means of the position}
      {of the sign bit in floating-point numbers}
      %integer Mone = -1
      %longreal M = Mone
      %byteinteger B = Byteinteger(Addr(M))
      %true %if B = 0 %or B = 16_BF
      %false
   %end

   %routine Convert Format(%record(Stackfm)%name V, %integer Type)
      %real Single
      %integer A = V_Rhigh,
               B = V_Rlow,
               Fh, Fl, S, X
      %unless A = 0 = B %or On IEEE %start
         {first dismantle VAX form of FP numbers}
         Fh = (A&2_1111111)<<16 ! (A>>16)         {top 23 bits of FP number}
         FL = (B&16_FFFF)  <<16 ! (B>>16)         {low 32 bits of FP number}
         X = (A>>7)                               {true exponent}
         X = X&255-128
         S = A>>15&1                              {sign bit}
         %if Type = Lreals %start
            X = (X+1023-1)&2_111 1111 1111        {NS exponent}
            B = (Fh&7)<<29 ! (Fl>>3)
            A = S<<31 + X<<20 + (Fh>>3)&16_000FFFFF
         %else      {reals}
            X = (X+127-1)&2_1111 1111
            A = S<<31 + X<<23 + Fh
            B = 0
         %finish
      %else %if Type = Reals                   {convert to short real}
         Single = V_Rval
         A = Integer(Addr(Single))
         B = 0
      %finish
      V_Rhigh = A
      V_Rlow  = B
%end

%routine To Short Real(%record(Stackfm)%name V)
   %integer X, Y, Exp, S
   %return %if V_Rhigh = 0 = V_Rlow
   %if On IEEE %start
      Real(Addr(V_Rval)) = V_Rval
   %else
      X = V_RHigh;  S = X
      Y = V_Rlow
      Exp = ((X>>20)&2_111 1111 1111) - 1023 + 1   {true exponent}
      Exp = Exp + 127 -1                           {short format}
      X = (X&2_0000 0000 0000 1111 1111 1111 1111 1111)<<3
      X = X ! (Y>>(32-3))                          {extra bits from mantissa}
      X = X+1 %if Y&16_1000 0000 # 0               {round it}
      %if X&16_0080 0000 # 0 %start                {need to normalise}
         X = X>>1
         Exp = Exp+1
      %finish
      X = X ! (Exp&255)<<23
      X = X ! 16_8000 0000 %if S < 0
      V_Rhigh = X
      V_Rlow  = 0
   %finish
%end

%include "inc.REALCON"

%integerfn Four Bytes
   %integer A,B,C,D
   A = Pending
   Readsymbol(B)
   Readsymbol(C)
   Readsymbol(D)
   Readsymbol(Pending)
   %result = ((A<<8+B)<<8+C)<<8+D
%end

%routine Input Integer Value(%integer Byte)
   Constant Type = Integers
   %if Byte = 0 %start
      Value_Integer = Four Bytes
   %else
      Value_Integer = Pending;  Readsymbol(Pending)
   %finish
   %if Pending = 'U' %start
      Value_Integer = -Value_Integer
      Readsymbol(Pending)
   %else %if Pending = '\'
      Value_Integer = \Value_Integer
      Readsymbol(Pending)
   %finish
   Stack Integer(Value_Integer) %unless Pending = 'A' {%or Pending = '$'}
%end

%routine Input Real Value
   Constant Type = Reals
   Value_Real = Real Constant
   %if Pending # 'A' %and Pending # '$' %start
      Stack Integer(0)
      %unless Value_Real = 0 %and (Pending = 'S' %or Pending = '?') %start
             {preserve true zero}
             {beware - a C-oid parameter 0.0 MUST retain}
             {its real-ness otherwise the wrong amount}
             {gets stacked}
         Stack_Type = Lreals;  Stack_Rval = Value_Real
         Convert Format(Stack, Lreals)
      %finish
   %finish
%end

%routine Input String Value
   %record(Stackfm)%name W
   Constant Type = Strings
   Get String(Value_String)
   %return %if Pending = '$' %or Pending = 'A'
   %if Length(Value_String) = 1 %start
      Stack Integer(Charno(Value_String, 1))
      Stack_Bias = -1
   %else
      W == Const String
      W_Stack == Stack
      Stack   == W
   %finish
%end

{Testing Predicates}

%predicate InReg(%record(Stackfm)%name V)
   %false %if V == Nil             -
          %or V_Form    # Address  -
          %or V_Disp    # 0        -
          %or V_Base    = 0        -
          %or V_Area    # 0        -
          %or V_Oper    # 0        -
          %or V_Index  ## Nil      -
          %or V_Record ## Nil
   %true
%end

%predicate Floating(%record(Stackfm)%name V)
   %true %if Reals <= V_Type <= Lreals %or V_Oper >= RNEGx
   %false
%end

%predicate Same(%record(Stackfm)%name A, B)
   %true %if A == B
   %false %if A == Nil %or B == Nil
   %false %if A_Disp   # B_Disp    %or
              A_Base   # B_Base    %or
              A_Type   # B_Type    %or
              A_Form   # B_Form    %or
              A_Extra  # B_Extra   %or
              A_Area   # B_Area
   %if A_Index ## Nil %start
      %false %unless B_Index ## Nil                 -
                %and A_Xsize = B_Xsize              -
                %and Same(A_Index, B_Index)         -
                %and A_Index_Oper = B_Index_Oper    -
                %and Same(A_Index_Link, B_Index_Link)
   %else
      %false %if B_Index ## Nil
   %finish
   %if A_Record ## Nil %start
      %false %unless B_Record ## Nil               -
                %and Same(A_Record, B_Record)      -
                %and A_Record_Oper = B_Record_Oper -
                %and Same(A_Record_Link, B_Record_Link)
   %else
      %false %if B_Record ## Nil
   %finish
   %true
%end

%predicate Const(%record(Stackfm)%name V)
   %false %if V_Form # Address %or
              V_Base # 0       %or
              V_Oper # 0       %or
              V_Index ## Nil   %or
              V_Record ## Nil  %or
              V_Area # 0
   %true
%end

%predicate Iconst(%record(Stackfm)%name V)
   %false %if V == Nil         -
          %or V_Form # Address -
          %or V_Base # 0       -
          %or V_Oper # 0       -
          %or V_Index ## Nil   -
          %or V_Record ## Nil  -
          %or V_Type > Addrs   -
          %or V_Area # 0
   %true
%end

%predicate Iconst Item(%record(Stackfm)%name V)
   {Same as ICONST but ignores the OPER field}
   %false %if V == Nil         -
          %or V_Form # Address -
          %or V_Base # 0       -
          %or V_Index ## Nil   -
          %or V_Record ## Nil  -
          %or V_Type > Addrs   -
          %or V_Area # 0
   %true
%end

%integerfn Power(%integer N)
   %integer P, Mask
   %result = -1 %if N > (  \( (-1)>>1 ) )>>1   {Beware x'4001' etc.}
   Mask = 1
   P = 0
   %cycle
      %result =  P %if Mask = N
      %result = -1 %if Mask > N
      Mask = Mask<<1
      P = P+1
   %repeat
%end

%integerfn Item Size(%integer F)
   %result = F %if F >= 0
   %result = Var(-F)_Format
%end

%record(Stackfm)%map Claim Work Area(%integer Bytes, Type)
   %record(Stackfm)%name T
   %record(Workfm)%name W, Best == NIL
   %integer P
   Fail("claim work area/1") %if Bytes <= 0
   P = Work Base
   %cycle
      %if P = Last Work %start             {no suitable one available}
         %if Best == NIL %start
            Last Work = Last Work+1;  Best == Work Area(Last Work)
            Frame = (Frame-Bytes)&(\3)
            Best_Size = Bytes;  Best_Displacement = Frame
         %finish
         W == Best
         %exit
      %finish
      P = P+1;  W == Work Area(P)
      Monitor N(P, "try work") %if Diag&MonStack # 0
      %if W_Validity < Work Validity %and W_Size >= Bytes %start
         %exit %if W_Size = Bytes
         Best == W %if Best == NIL %or Best_Size > W_Size
      %finish
   %repeat
   W_Validity = Work Validity      {prevent its re-use}
   Monitor N(W_Displacement, "temporary") %if Diag&MonStack # 0
   T == Literal(W_Displacement)
   T_Base = Local;  T_Type = Type;  T_Form = Direct;  T_Format = Bytes
   %result == T
%end

%routine Constant Bounds
   Vub = Popped Value
   Vlb = Popped Value
%end

%routine Set CD(%integer Value, %integername CD)
   CD = Value&x'3FFF' %if Value&x'C000' = 2<<14
%end

%Predicate Alternate format(%integer Code)
   %integer Attr = 0
   %record(Varfm) Dummy
   %if Code = 'A' %start           {Start of alternatives}
      Assemble(Dummy, -2, Vars, Local, -1, Attr)
      Alt Align = Alt Align&Falign
   %else %if Code = 'C'            {Next alternative}
      Max Frame = Frame %if Frame > Max Frame
      Frame = Frame Base
   %else %if Code = 'B'            {End of alternatives}
      Frame = Max Frame %if Max Frame > Frame
      Falign = Alt Align
      %true
   %else
      Fail("Format ".ItoS(Code, 0))
   %finish
   %false
%end

%routine Compile Begin
   %integer Main Ep = 0
   %record(Varfm) B
   B = 0                           {Dummy heading}
   B_Type = Generals
   B_Disp = New Label
   B_Base = None                   {show an internal routine}
   %if Local # Base Local %start   {internal}
      Stack Integer(B_Disp)
      Stack_Flags = Stack_Flags!Nasty Proc %if Local >= Danger Level
      Call(0)
      Ostate = 0
   %else
      Ostate = External
      External Id = "3L___main_program"
      Entry Point = External No+1
      Main Ep = 1
   %finish
   Internal Id = "block"
   Internal Id = Alias %and Alias = "" %if Alias # ""
   Assemble(B, 0, Vars, Local+1, 0, Attributes)
%end

%routine Clear Vars(%integer Limit)
   Fail("Too many objects") %if Limit >= Parms
   %while Vars < Limit %cycle
      Vars = Vars+1
      Var(Vars) = 0
   %repeat
%end

{Var control}

   %routine DIR String(%integer Op, %string(*)%name S)
      %integer L = Length(S), J
      Dir1(Op) %if Op >= 0
      Dir1(L)
      Dir1(Charno(S, J)) %for J = 1, 1, L
   %end

   %routine Dump External(%integer Code, %record(Varfm)%name V)
      External No = External No+1
      %if Code&1 = 0 %start                                {spec}
         %if V_Form = Proc %then V_Area = Dir Xcall    %and V_Disp = External No -
                           %else V_Area = -External No %and V_Disp = 0
      %finish
      Code = Code!4 %if Code&2 # 0 %and V_Flags&Prim Proc # 0 {not Prim proc}
      DIR String(Dir Ext, External Id)
      Dir2(Code, V_Disp)
   %end

   %routine Plant Diag(%record(Diagfm)%name D)
      %integer Disp, Type, Ind, Base, BType, PType
      %record(Afm)%name Dv
      %return %if D_X&64 # 0 %and D_Format&16_FFFF = 0
      Disp = D_Var_Disp
      Disp = D_Ext %if D_Ext # 0                       {external data}
      Type = (D_X>>2)&15
      %if Interface_Options&LL Vars # 0 %and Type # 14 %start
         Dir String(Dir Diag, D_Id)
         Dump Encoded(D_X)
         Dump Encoded(D_Xtype)
         Dump Encoded(D_Var_Disp)
         Dump Encoded(D_Format&16_FFFF) %if D_X&64 # 0        {records}
      %finish
      %if DEBUG # 0 %start
         Base = D_X&3
         Ind  = D_X>>7
         Btype = D_XType&15
         PType = (D_XType>>4)&15
         %if Type = 14 %start                     {Array}
            Dir String(Dir DEBUG Array, D_Id)
            Dv == D_Var_Adata
            Dump Encoded(Dv_Bound(1)_Lower)
            Dump Encoded(Dv_Bound(1)_Upper)
            Dump Encoded(Dv_Total Size)
            Dump Encoded(Btype)                   {base (element) type}
            Dump Encoded(D_Format&16_FFFF)        {Pointer to format}
         %else
            %return %if Base # 1 %and Base # 2
            Dir String(Dir DEBUG Var, D_Id)       {Variable identifier}
            Dump Encoded(Type)                    {Primary type}
            Dump Encoded(Ind)                     {Indirect bit - VAR}
            Dump Encoded(Base)                    {Addressing base}
            Dump Encoded(Btype)                   {Base type of pointer}
            Dump Encoded(PType)                   {Type pointed at}
            Dump Encoded(D_Var_Disp)              {Displacement from base}
            Dump Encoded(D_Format&16_FFFF)        {Pointer to format}
            Dump Encoded(Item Size(D_Var_Format)) {object size}
         %finish
      %finish
   %end

   %routine Dump Diag(%integer Base, %record(Qfm)%name Q)
      %record(Diagfm) D
      %record(Diagfm)%name ND
      %return %if Compiling Prim # 0
      D_Link  == Diag List                      {here to prevent UNASS from VAX}
      D_Id     = Internal Id
      D_Xtype  = 0
      D_Ext = 0
      %if Base = Any %start
         %return %if Parameter List = 0
         Base = 0
         D_Xtype = (Q_Dtype>>2)&15
         Q_Dtype = 14<<2
      %else %if Base = Local
         Base = 1
      %else %if Base = SB
         Base = 2
      %else %if Base < 0
         D_Ext = -Base;  Base = 3
      %else
         Base = 0
      %finish
      %if Q == Nil %start
         D_X = 0
         D_Format = 0
      %else
         D_Format = Q_Dform
         %if Q_Pointed ## Nil %start
            D_Xtype = Q_Dtype>>2 ! (Q_Pointed_Dtype>>2&15)<<4
            Q_Dtype = Q_Dtype ! 15<<2 ! Q_Pointed_Dtype&64    {escape}
            D_Format = Q_Pointed_Dform
         %finish
         D_X = Q_Ind<<7 ! Q_Dtype ! Base
      %finish
      D_Var == DefV
      %return %if D_Format = 0 %and D_X&64 # 0 {record(*)name}
      %if Parameter List = 0 %start            {not in record or parameters}
         Plant Diag(D)
      %else
         ND == NEW(Diagfm Type)
SYY:     ND = D
         Diag List == ND                       {_Link set up above}
      %finish
   %end

   %routine Flush Diags
      %routine Flush(%record(Diagfm)%name D)
         %return %if D == NIL
         Flush(D_Link)
         Plant Diag(D)
         Dispose(D)
      %end
      {The list is currently backwards - reverse it to preserve order}
      Flush(Diag List)
      Diag List == NIL
   %end

   %routine Define Var
      %integer Decl, Tf, NewV, Area, External Mode
      %integername At
      %integer Spec, Oflags, N,
               Type,                     {external item type}
               Form,                     {external item form}
               Format                    {external item size or format}

      %record(Varfm)%name Fv
      %record(Qfm) Q, Pq
      %record(Stackfm)%name Vv

      %constbytearray Form Map(0:15) = 0,         {Unknown}
                                       Direct,    {integer}
                                       Indirect,  {integername}
                                       0(4),      {label/format/?/switch}
                                       Proc(4),   {rt/fn/map/pred}
                                       Direct,    {array}
                                       Direct,    {arrayname}
                                       Direct,    {namearray}
                                       Direct,    {namearrayname}
                                       0

      %routine Encode Type(%integer Type, Format, %record(Qfm)%name Q)
         %switch T(-3:10)
         %constshortarray DiagMap(-3:10) =
                     5<<2     {-3},  3<<2    {-2},  2<<2   {-1},
                        0      {0},
                     1<<2      {1},  4<<2     {2},  6<<2    {3},  7<<2!64 {4},
                     8<<2      {5}, 13<<2     {6}, 10<<2!64 {7}, 11<<2!64 {8},
                    12<<2      {9},  9<<2    {10}
         %constbytearray TypeMap(-3:10) =
                     Lreals {-3},  Bytes  {-2}, Shorts {-1},
                    Generals {0},
                    Integers {1},   Reals  {2}, Strings {3},  Records {4},
                       Bytes {5},    Sets  {6},   Bytes {7},   Shorts {8},
                    Integers {9},   Bytes {10}
         %constbytearray SizeMap(-3:10) =
               WordLength*2 {-3},          1  {-2},   2 {-1},
               WordLength*3  {0},
                WordLength   {1}, WordLength*1 {2},   0  {3},  0   {4},
                         1   {5},    Set Size  {6},   1  {7},  2   {8},
                WordLength   {9},          1  {10}
         %constbytearray AlgnMap(-3:10) =
                          3 {-3},  0 {-2}, 1 {-1},
                          3  {0},
                          3  {1},  3  {2}, 0  {3}, 0  {4},
                          0  {5},  3  {6}, 0  {7}, 1  {8},
                          3  {9},  0 {10}

         %if Type = 1 %start {split integers}
            %if Format = 2 %then Type = -2 {bytes} %else -
            %if Format = 3 %then Type = -1 {short}
         %else %if Type = 2  {split reals}
            %if Format = 4 %then Type = -3 {longreal}
         %finish

         Fail("Unknown type") %unless -3 <= Type <= 10

         Q_Type    = TypeMap(Type)
         Q_Size    = SizeMap(Type);  DefV_Format = Q_Size
         Q_Round   = AlgnMap(Type)
         Q_Bias    = 0
         Q_Dtype   = DiagMap(Type)
         Q_Dform   = 0
         Q_Format  = Format
         Q_Diags   = 1                   {assume diags are sensible}
         Q_Ind     = 0                   {assume not indirect}
         Q_Pointed == Nil

         ->T(Type)

T(0): {general}            Q_Diags = 0;  %return

T(-3):{long}
T(1): {integer}
T(2): {real}
T(5): {boolean}            DefV_Flags = DefV_Flags ! Checkable
T(-1):{short}
T(-2):{byte}
T(10):{char}               %return

T(3): {string}             Q_Size      = Format+1
                           DefV_Format = Q_Size
                           %return

T(4): {record}             Fv == Var(Format)
                           %if Format > Vars %start
                              Clear Vars(Format)
                              Interface_Formats = Interface_Formats+1
                              Fv_Area = Interface_Formats
                           %else
                              Q_Size = Fv_Format
                           %finish
                           DefV_Format = -Format
                           Q_Round     = Fv_Disp        {alignment required}
                           Q_Dform     = Fv_Area        {diagnostic index}

T(7): {byte enumerated}    Q_Dform = Var(Format)_Area;  %return

T(8): {short enumerated}   Q_Dform = Var(Format)_Area;  %return

T(9): {pointer}           DefV_Flags = DefV_Flags ! Checkable
T(6): {set}               %if Q ## Pq %start
                              Encode Type(Q_Dim, Format, Pq)
                              DefV_Format = SizeMap(Type) {restore it}
                              Q_Pointed == Pq
                           %else
                              Q_Diags = 0
                           %finish
                           %if Type = 6 {sets} %start
                              {beware of a checkable base type}
                              DefV_Flags = DefV_Flags & (\Checkable)
                           %finish
                           %return

      %end {of encode type}

      NewV  = 1
      Decl = Tag
      %if Decl # 0 %start                {normal item}
         NewV = 0 %if Decl <= Vars
         DefV == Var(Decl);  Clear Vars(Decl)
      %else                     {format item}
         Parms = Parms-1
         DefV == Var(Parms);  DefV = 0
      %finish
      Fail("Too many objects") %if Parms <= Vars

      Internal Id = ""
      %while Pending # ',' %cycle
         %if Length(Internal Id) # 127 %start
            Internal Id = Internal Id.Tostring(Pending)
         %finish
         Readsymbol(Pending)
      %repeat
      Readsymbol(Pending)

      Tf     = Tag
      Format = Tag
      Ostate = Tag

      Q_Dim         = Ostate>>8
      Spec          = Ostate&8
      Oflags        = Ostate&16_F0
      Ostate        = Ostate&7;  Ostate = External %if Ostate = Dynamic
      Type          = Tf>>4&15
      Form          = Tf&15

      %if Alias # "" %start
         Ostate = External %if Ostate = System
         External Id = Alias;  Alias = ""
      %else %if Ostate = System
         Ostate = External
         External Id = "$".Internal Id
      %else
         External Id =     Internal Id
      %finish
      External Mode = Ostate

      %if Form = 0 %and Decl = 0 %start          {special for enumerated types}
         Parms = Parms+1
         Dump Diag(0, Nil)
         %return
      %finish

      Encode Type(Type, Format, Q);  Q_Diags = 0 %if Internal Id = ""

      DefV_Type = Q_Type
      %if Oflags&16 # 0 %start                     {indirect}
         DefV_Type = Integers;  DefV_Format = 4
         Q_Ind = 1;  Q_Size = 4;  Q_Round = Alignment;  Q_Bias = 0
         Form = 1
      %finish
      Q_Bias = 0 %if Form # 1
      DefV_Flags = DefV_Flags!Checkable %if Oflags&32 # 0
      Decl Size = Q_Size
      DefV_Form = Form Map(Form)

      %if Form = 4 %start                                {recordformat}
         DefV_Extra = Parms
         Parameter Mode = -1;  Block Type = -1
         %if DefV_Area = 0 %start
            Interface_Formats   = Interface_Formats+1
            DefV_Area = Interface_Formats  {diagnostic index}
         %finish
         %return
      %else %if Form = 3                                 {label}
         Set User Label(Decl)
         %if Language Flags&Pascal Flag # 0 %start
            Save Wsp %if Wsp Save = 0
            DefV_Extra = Wsp Save
         %finish
      %else %if Form = 6                                 {switch}
         DefV_Area     = Free Label-Vlb+1       {zero'th tag}
         DefV_Disp     = Vlb                    {lower bound}
         DefV_Extra    = Vub                    {upper bound}
         N = Free Label+1
         Free Label = N+Vub-Vlb
         Constant Base = (Constant Base+3)&(\3) {align it}
         Select Constant Area
         DefV_Format   = Ca                     {address of vector}
         Dump Word(Vub)                         {upper}
         Dump Word(Vlb)                         {lower}
         Dir3(Dir Swdef, N, Free Label)
         Constant Base = Constant Base+4*(Vub-Vlb+1)
         Select Code Area
      %else %if 7 <= Form <= 10                          {rt, fn, map, pred}
         Parameter Mode = 1
         Block Type     = Spec                           {0=def, 8=spec}
         %if 8 <= Form <= 9 %start                       {fn/map}
            DefV_Flags = DefV_Flags!Answer
            %if Form = 9 %start                          {map}
               DefV_Flags = DefV_Flags!Defered
            %else %if DefV_Type <= Addrs                 {integral function}
               DefV_Type = Integers                      {all results integers}
            %finish
         %else %if Form = 10                             {predicate}
            DefV_Flags = DefV_Flags!Pred Call
         %finish
         %if External Mode = OWN %start
            External Mode = External
            Ostate        = External
            DefV_Flags = DefV_Flags ! Keep Local
         %else %if External Mode >= Primrt
            %if External Mode = PrimRt %start
               Defv_Flags = Defv_Flags!Primitive
               Defv_Prim  = Q_Dim
            %else
               Defv_Flags = DefV_Flags!Prim Proc
            %finish
            External Mode = External
            Ostate        = External
         %finish
         %if Parameter List > 0 %start        {proc variable}
                                              {beware - a spec will follow}
                                              {which must not corrupt flags}
            Danger Marker = 1
            Frame = (Frame+3)&(\3)            {keep word aligned}
            DefV_Disp  = Frame
            DefV_Base  = Local
            DefV_Flags = DefV_Flags!Parameter
            Frame = Frame + Word Length*2
         %else %if Local >= Danger Level
            DefV_Flags = DefV_Flags!Nasty Proc
         %finish
      %else
         %if Form = 11 %or Form = 13 %start          {array or namearray}
            Q_Diags = 0
            %if Form = 13 %start                     {namearray}
               Decl Size  = Word Length
               Decl Size  = Word Length*2 %if Q_Type = Strings  -
                                         %and Q_Size = 1      {string(*)%namearray}
               DefV_Flags = Defered
               Q_Round = Alignment
            %finish
            Q_Size  = 0                              {no space allocated here}
         %else %if Form = 2                          {%name}
            Q_Ind   = 1
            Q_Round = Alignment
            %if Q_Type # Generals %start
               Decl Size = Word Length
               Decl Size = Word Length*2 %if Q_Type = Strings  -
                                        %and Q_Size = 1       {string(*)name}
               Q_Size = Decl Size
            %finish
         %else %if Form = 1                       {simple variable}
            %if Parameter List > 0 %and (Q_Type = Strings   -
                                     %or Q_Type = Records   -
                                     %or Q_Type = Sets)    %start
               Q_Size = Word Length
               DefV_Flags = DefV_Flags!Awanted %if Oflags&16 = 0
            %finish
         %else                                    {arrayname or namearrayname}
            Q_Diags = 0
            Q_Round = Alignment
            Q_Size  = Word Length*2
            DefV_Flags = Defered %if Form = 14    {namearrayname}
            DefV_Flags = DefV_Flags!Arrayname
         %finish
         %if External Mode = 0 %start                      {automatic}
            DefV_Base = Local
            %if Decl = 0 %start                            {record}
               Frame = (Frame+Q_Round)&(\Q_Round)
               Defv_Disp = Frame;  Frame = Frame+Q_Size
            %else %if Parameter List > 0                   {parameters}
               Q_Round = 3 %if Q_Round < 3
               Q_Size  = 4 %if Q_Size  < 4
               Frame   = (Frame+3)&(\3)                    {keep parameters word aligned}
               DefV_Disp = Frame
               Frame = Frame+Q_Size
            %else
               %if Q_Size > 256 %start                     {allocate dynamically}
                  Q_Ind = 1
                  Frame = Frame&(\3)-4                     {1 word slot}
                  DefV_Disp = Frame;  DefV_Form = Indirect
                  DefV_Flags = DefV_Flags&(\Checkable)
                  N = (Q_Size+3)&(\3)                      {round up size}
                  Attributes = Attributes!Attr Sp Unknown
                  %if Unassigned # 0 %start                {set it unassigned}
                     Attributes = Attributes!Attr Needs Gp
                     Vv == Literal(N)
                     Load(Vv, R4)
                     Release and Drop(Vv)
                     Prim(Dalloc)                          {alters SP}
                  %else
                     Vv == Local Integer(-N)
                     Vv_Base = Sp;  Vv_Form = Address
                     Load(Vv, Sp)                          {adjust Sp}
                     Drop(Vv)
                  %finish
                  Vv == Local Integer(Frame)
                  Plant2(STR, Sp, Vv)                      {initialise pointer}
                  Release and Drop(Vv)

                  %if wsp save # 0 %start                  {done it, => wrong}
                     save wsp                              {do it again}
                  %finish                                  {quick hack}

               %else
                  Frame = Frame&(\Q_Round)-Q_Size
                  DefV_Disp = Frame
               %finish
            %finish
            DefV_Flags = DefV_Flags!Known Ass %if Tf&256 # 0
            Dump Diag(Local, Q) %if Q_Diags#0 %and Amode <= 0
         %else                                             {own/external}
            Ownextra = 0
            %if Spec = 0 %start                            {definition}
               Init Flag = 0
               OwnType = Q_Type;  OwnForm = Form
               %if External Mode = Con %start              {const something}
                  %if Form = 2  {constname}           -
                  %or Form = 12 {constarrayname}      -
                  %or Form = 14 {constnamearrayname}  %start
                     DefV_Form = Direct
                     Init Flag = -1
                     %return
                  %finish
                  Constant Base = (Constant Base+3)&(\3)   {align it}
                  Area = Constant Area;  At == Constant Base
                  DefV_Area = Constant Area
                  Q_Diags = 0
               %else                                       {ownish}
                  Area = Own Area;       At == Own Base;       DefV_Base = Sb
                  %if Form = 11 %or Form = 13 %start     {array or namearray}
                     Own Array Base = (Own Array Base+3)&(\3)
                     Area = Own Array Area;  At == Own Array Base
                     Ostate = 255  {flag for INIT}
                  %finish
               %finish
               Ownextra = 1 %if Ownform = 12 %or Ownform = 14 {..arrayname}
               Ownextra = 1 %if Owntype = Strings    -
                           %and DefV_Format = 1      -
                           %and (Ownform = 2 %or Ownform = 13)
                                {string(*) name & namearray}
               OwnType = Integers %and Q_Round = 3 %if OwnForm # 1  -
                                                  %and OwnForm # 11
               At = (At+Q_Round)&(\Q_Round)
               DefV_Disp = At
               %if Form = 11 %or Form = 13 %start          {array or namearray}
                  DefV_Flags = DefV_Flags!Arrayname
                  N = DefV_Disp-Vlb*Decl Size      {back to A(0)}
                  Own Base = (Own Base+3)&(\3)
                  DefV_Base = SB;  DefV_Disp = Own Base;  DefV_Area = 0
                  Select Own Area
                  Dir4(Dir Header, Area>>8, N, 0);  Ca = Ca+8
                  Select Code Area
                  Value = Default Value
                  Init Flag = 1
                  {dummy dope-vector}
                  DefV_Adata == New(A Type)
SYY:              DefV_Adata = 0
               %finish
               %if External Mode = External %start
                  Dump External(2_01, DefV)
                  DefV_Area = 0                            {beware prior %spec}
                  DefV_Flags = DefV_Flags&(\XData Spec)    {  "      "     "  }
               %finish
               Dump Diag(DefV_Base, Q) %if Q_Diags # 0
            %else                                          {external data spec}
               DefV_Flags = DefV_Flags ! XData Spec
               DefV_Flags = DefV_Flags!Arrayname %if Form = 11 %or Form = 13
               Dump External(2_00, DefV)
            %finish
         %finish
      %finish
      Alt Align = Alt Align&(\Q_Round)            {remember worst alignment}
      Round = Q_Round
      Dtype = Q_Dtype    {remember for arrays (dimension)}
   %end

   %routine Dump Text(%integer Max)
      %integer J, Len
      Len = Length(Value_String)
      %if Max = 0 %start            {no upper limit}
         Max = Len                  {use the actual length}
      %else                {check the length}
         Len = Max %and Warn(0, "String truncated") %if Len > Max
      %finish
      Dump Byte(Len)
      %for J = 1, 1, Max %cycle
         %if J > Len %then Dump Byte(0) -
                     %else Dump Byte(Charno(Value_String, J))
      %repeat
   %end

   %routine Adump
      %record(Stackfm) Rv
      %integer J, Disp, Key
      %if OwnType = Integers %or OwnType = Addrs %start
         %if Stack == Nil %start                 {the easy case}
            Dump Word(Value_Integer)
         %else
            %if Stack_Record ## NIL %start
               Fail("Adump/0")
            %else
               Simplify(Stack)
               Disp = Stack_Disp
               Fail("Adump/1") %unless Stack_Record== Nil %and Stack_Index == Nil
               %if Stack_Form = Address %start
                  %if Stack_Base = SB %start
                     Key = 0
                  %else %if Stack_Base = None
                     %if Stack_Area = Constant Area %start
                        Key = -1
                     %else
                        Key = -Stack_Area
                        Fail("Adump/4") %if Key <= 0
                     %finish
                  %finish %else Fail("Adump/2")
                  Dir3(Dir Init, Key, Disp)
               %finish %else Fail("Adump/3")
            %finish
            Ca = Ca+4
            Pop Release and Drop
         %finish
      %else %if Owntype = Bytes %or Owntype = Booleans
         Warn(0, "value truncated to 8 bits unsigned") %unless 0 <= Value_Integer <= 255
         Dump Byte(Value_Integer)
      %else %if OwnType = Shorts
         Warn(0, "value truncated to 16 bits signed") %unless 16_FFFF 8000 <= Value_Integer <= 16_0000 7FFF
         Dump Half(Value_Integer)
      %else %if OwnType = Reals %or OwnType = Lreals
         Rv_Rval = Value_Real;  Convert Format(Rv, Owntype) {BEWARE: = 1.3(12) etc}
         Dump Word(Rv_Rhigh)
         Dump Word(Rv_Rlow ) %if Owntype = Lreals
      %else %if OwnType = Strings
         Dump Text(Decl Size-1)
      %else %if OwnType = Records %or Owntype = Sets
         Dump Byte(0) %for J = 1, 1, Decl Size
      %finish %else Fail("Init")
      %while Ownextra > 0 %cycle
         Dump Word(0)
         Ownextra = Ownextra-1
      %repeat
   %end

   %routine Init(%integer N)
      %if Stack ## Nil %and Iconst(Stack) %start
         Value_Integer = Stack_Disp
         Constant Type = Integers
         Pop Release and Drop
      %finish
      %if Reals <= OwnType <= Lreals %start
         Value_Real = Value_Integer %if Constant Type = Integers
      %finish
      %if Init Flag < 0 %start          {const?name}
         DefV_Disp = Value_Integer
      %else
         %if Ostate = Con %then Select Constant Area  %else -
         %if Ostate = 255 %then Select Own Array Area       -
                          %else Select Own      Area
         %while N > 0 %cycle
            N = N-1;  Adump
         %repeat
         Select Code Area
      %finish
      Value = Default Value                {Restore the default values}
      DefV_Flags = DefV_Flags!Known Ass
   %end

   %routine Dimension(%integer Dim, N)
      { %integerarray  A(1:5)  Base+Disp = Header (Direct) !Array!Static X=DV}
      { %integerarray  B(1:N)  Base+Disp = Header (Direct) !Arrayname        }
      { %integerarray _C(1:5)  Base+Disp = A(0)   (Direct) !Array        X=DV}
      { %integerarrayname D    Base+Disp = Header (Direct) !Arrayname        }

      %integer X, Static Array = 0, J
      %record(Varfm)%name V
      %record(Afm) Dope
      %record(Stackfm)%name B, Total, DopeVector, Zero, Header
      %record(Stackfm)%name L1, L2, U1, U2, M1, M2
      %record(Qfm) Q

      %predicate All Const
         %record(Stackfm)%name P
         %record(Boundfm)%name B
         %integer J, N
         P == Stack
         N = Decl Size
         %for J = Dim, -1, 1 %cycle
            B == Dope_Bound(J)
            %false %unless Iconst(P);  B_Upper = P_Disp;  P == P_Stack
            %false %unless Iconst(P);  B_Lower = P_Disp;  P == P_Stack
                                       B_Mult  = N
            N  = B_Upper-B_Lower+1
            Fail("Array inside-out") %if N < 0
         %repeat
         Dope_Total Size = N             {remember final bound}

         {A constant dope-vector}

         Dope_Base              = Local
         Dope_Dimension         = Dim
         Dope_Zero Displacement = 0
         N = 0
         %for J = 1, 1, Dim %cycle
            B == Dope_Bound(J)
            Dope_Zero Displacement = Dope_Zero Displacement*N-B_Lower
            N = B_Mult
            Dope_Total Size = Dope_Total Size*N
         %repeat
         Dope_Zero Displacement = Dope_Zero Displacement*N
         Pop Release and Drop %for J = 1, 1, Dim*2
         Static Array = 1
         Constant Base = (Constant Base+Alignment)&Alignment Mask
         Dope_Dv = Constant Base
         %if Parameter List = 0 %start
            Dope_Total Size = (Dope_Total Size+3)&(\3) {word align it}
         %finish
         Select Constant Area
         Dump Word(Dim)
         Dump Word(Dope_Total Size)
         Dump Word(Dope_Zero Displacement)
         %for J = 1, 1, Dim %cycle
            B == Dope_Bound(J)
            Dump Word(B_Lower)
            Dump Word(B_Upper)
            Dump Word(B_Mult)
         %repeat
         Select Code Area
         %true
      %end

      Attributes = Attributes ! Attr Sp Unknown

      {Create dope-vector}

      %if All Const %start                {constant dope-vector}
         %return %if N = 0                {own dope vector}
         %if Parameter List # 0 %start    {in format}
           X = Parms+N
           Frame = (Frame+Round)&(\Round)
           %while N > 0 %cycle
              N = N-1
              X = X-1;  V == Var(X)
              V_Disp = Frame+Dope_Zero Displacement
              Frame = Frame+Dope_Total Size
              V_Form = Direct
              V_Flags = V_Flags!Array
              V_Adata == New(A Type)
SYY:          V_Adata = Dope
              %if Debug # 0 %start
                 Q_Dform = 0
                 Q_Dform = Var(-V_Format)_Area %if V_Format < 0
                 Q_Pointed == NIL
                 Q_Ind = 0
                 Q_Dtype = Dtype
                 DefV == V
                 Dump Diag(Any, Q)
              %finish
           %repeat
           %return
         %finish
         Zero       == Nil
         Zero       == Literal(Dope_Zero Displacement) -
                           %if Dope_Zero Displacement # 0
         Total      == Literal(Dope_Total Size)
         DopeVector == Literal(Dope_Dv)
         DopeVector_Form = Address;  DopeVector_Area = Constant Area
         Load(DopeVector, R3)
         Load(Zero,  R2) %unless Zero == Nil
         Load(Total, R1)
      %else                                 {dynamic dope-vector}
         %if Dim = 1 %start                 {special case fir 1 dimension}
            U1 == Stack;  Stack == U1_Stack {upper bound}
            L1 == Stack;  Stack == L1_Stack {lower bound}
            M1 == Literal(Decl Size)
            Load Trio(U1, R4, L1, R3, M1, R5)
            Release and Drop Pair(L1, U1);  Release and Drop(M1)
            Prim(Dynamic 1)
         %else %if Dim = 2                  {special case for 2 dimensions}
            U2 == Stack;  Stack == U2_Stack {upper bound}
            L2 == Stack;  Stack == L2_Stack {lower bound}
            M2 == Literal(Decl Size)
            U1 == Stack;  Stack == U1_Stack {upper bound}
            L1 == Stack;  Stack == L1_Stack {lower bound}
            Load Pair(U1, R4, L1, R3)
            Load Trio(U2, R7, L2, R6, M2, R8)
            Load Pair(U1, R4, L1, R3)
            Load Trio(U2, R7, L2, R6, M2, R8)
            Release and Drop Pair(L1, U1)
            Release and Drop Pair(L2, U2);  Release and Drop(M2)
            Prim(Dynamic 2)
         %else
            X = Decl Size
            %for J = 1,1,Dim %cycle
               Push Literal(X);  X = 0
               B == Stack; Stack == B_Stack;  Push(B);  Release and Drop(B)
               B == Stack; Stack == B_Stack;  Push(B);  Release and Drop(B)
            %repeat
            Push Literal(0)
            Push Literal(0)
            Push Literal(Dim)
            Prim(Dynamic N)
                            {returns with:  R1 = Total size (rounded)}
                            {               R2 = Zero Displacement}
                            {               R3 = Dope Vector address}
         %finish
         Total      == Register(R1)
         Zero       == Register(R2)
         DopeVector == Register(R3)
      %finish

      {create the arrays}
      {a head looks like:  <address of A0> <address of dope-vector> }
      {                    ^               ^                        }
      {                    V_Disp          V_Disp+4                 }

      Frame = Frame & (\3)
      Header == Local Integer(Frame-Wordlength)
      Load Address(Header, R4)         {end of headers}

      X = Vars-N
      %while N > 0 %cycle
         N = N-1
         X = X+1;  V == Var(X)
         Frame = Frame-2*Wordlength
         V_Disp  = Frame                               {address of header}
         V_Flags = V_Flags!Known Ass!ArrayName
         V_Form  = Direct
         Plant1(SUB, Sp, Sp, Just(R1))              {claim space}
{This can be improved by using R4 or Sp for the zero'th address}
{but it needs dope-vectors to be the other way round?}
         %if Zero == NIL %start
            Plant1(MOV,  0, R0, Just(Sp))
         %else
            Plant1(ADD, Sp, R0, Just(R2))
         %finish
         Plant4(STM ! Write Back, R4, 16_0009)   {STM_<R0,R3>, R0 = zero'th}
      %repeat
      Release and Drop(Total)
      Release and Drop(Zero) %if Zero ## Nil
      Release and Drop(DopeVector)
      Release and Drop(Header)
   %end

   %routine Swop
      %record(Stackfm)%name T
      T           == Stack
      Stack       == T_Stack
      T_Stack     == Stack_Stack
      Stack_Stack == T
   %end

   %routine Define Range
      %integer T
      %record(Varfm)%name V
      T = Tag;  V == Var(T);  Clear Vars(T)
      Constant Bounds;  V_Disp = Vlb;  V_Extra = Vub;  V_Format = -1
   %end

   %routine Test Range(%record(Stackfm)%name S, %record(Varfm)%name V)
      %record(Stackfm)%name R, L, U, Low, High
      %return %if Interface_Options&LL Range = 0
      %if S_Type = Sets %start
         Low  == Literal(V_Disp)
         High == Literal(V_Extra)
         Loadup(S) %if S_Oper # 0
         Build Set(S) %if S_Members ## Nil
         R == Copy(S);  Amap(R)
         Load Trio(Low, R1, High, R2, R, R0)
         Prim(Set Range)
         Release and Drop Pair(Low, High);  Release and Drop(R)
         %return
      %finish

      %if Iconst(S) %start
         %return %if V_Disp <= S_Disp <= V_Extra
         Warn(1, "Range violation")
      %finish


      Loadup(S)
      R == Copy(S)                      {so as not to destroy the register}
      U == Literal(V_Extra)
      %if V_Disp # 0 %start             {use dynamic range}
         L == Literal(V_Disp)
         Load Trio(R, R1, L, R2, U, R3)
         Prim(Dynamic Range)
         Release and Drop(L)
      %else
         Load Pair(R, R1, U, R3)
         Prim(Check Range)
      %finish
      Release and Drop Pair(R, U)
   %end

   %routine Duplicate
      %record(Stackfm)%name V
      V == Copy(Stack)
      V_Stack == Stack
      Stack == V
   %end

   %routine Stack Work Variable
      %integer T
      %record(Varfm)%name V
      T = Tag;  V == Var(T);  Clear Vars(T)
      %if V_Base = None %start                     {a new one}
         Frame = Frame&Alignment Mask-Wordlength
         V_Type = Integers;  V_Form = Direct
         V_Base = Local;     V_Disp = Frame
         V_Flags = Known Ass
      %finish
      Stack Var(T)
   %end

   %routine Claim With(%integer N)
      %integer Format
      %record(Withfm)%name W
      W == NEW(Withfm Type)
      W_Link == Withs;  Withs == W
      W_Key = N
      %if Stack_Index ## Nil %or Stack_Record ## Nil -
                             %or Stack_Form # Direct -
                             %or %not Locked(Stack_Base) %start
         Format = Stack_Format
         Amap(Stack); Stab(Stack)
         Stack_Format = Format
         Stack_Flags = Stack_Flags ! Stored With
      %finish
      W_Data = Stack_Data
      Pop Release and Drop
   %end

   %routine Release With(%integer N)
      %record(Withfm) Base
      %record(Withfm)%name W == Base, X
      Base_Link == Withs
      %while W_Link ## Nil %cycle
         %if W_Link_Key = N %start
            X == W_Link
            W_Link == X_Link
            Withs == Base_Link
            Dispose(X)
            %return
         %finish
         W == W_Link
      %repeat
      Fail("No use")
   %end

   %routine Use With(%integer N)
      %integer Format
      %record(Withfm)%name W == Withs
      %while W ## Nil %cycle
         %if W_Key = N %start
            Stack Integer(0)
            Stack_Data = W_Data
            %if Stack_Flags&Stored With # 0 %start
               Format = Stack_Format
               Vmap(Stack, Integers)
               Stack_Format = Format
            %finish
            %return
         %finish
         W == W_Link
      %repeat
      Fail("No use")
   %end

   %routine Build Set(%record(Stackfm)%name S)
      %record(Stackfm)%name W, Z, OldLink
      %record(Memberfm)%name M, X
      %recordformat Csetfm(%bytearray Set(0:31))     {32*8 = 256}
      %record(Csetfm) C
      %integer Dumped = 0, Marked = 0, In Work = 0, Low, High, Op, OldOper

      %routine Dump Set
         %integer J
         Dumped = 1
         Constant Base = (Constant Base+3)&(\3)   {align it}
         S_Type = Sets
         S_Disp = Constant Base;  S_Form = Direct;  S_Area = Constant Area
         Select Constant Area
         Dump Byte(C_Set(J)) %for J = 0, 1, 31
         Select Code Area
      %end

      %routine Mark(%integer N)
         %integer W
         %unless 0 <= N <= 255 %start
            Warn(1, "Set element out of range ".itos(N, 0))
            %return
         %finish
         W = N>>3
         C_Set(W) = C_Set(W) ! (1<<(N&7))
         Marked = 1
      %end

      Monitor(S, "Bset->") %if Diag&Monoperand # 0
      OldLink == S_Link;  S_Link == NIL
      OldOper  = S_Oper;  S_Oper = 0
      C = 0
      M == S_Members;  S_Members == Nil
      S_Flags = S_Flags&(\Null Set)
      %while M ## Nil %cycle
        X == M;  M == M_Link
        %if X_Const # 0 %start
           High = X_A_Disp;  Drop(X_A)
           %if X_B == Nil %start
              Mark(High)
           %else
              Low = X_B_Disp;  Drop(X_B)
              %while Low <= High %cycle
                 Mark(Low);  Low = Low+1
              %repeat
           %finish
        %else
           %if In Work = 0 %start
              W == Claim Work Area(Set Size, Sets)
              %if Marked # 0 %start
                 Dump Set %if Dumped = 0
                 Set Assign(S, W)
                 Release(S_Base)        {it's going to be copied over soon}
                 Marked = 0
              %else
                 Z == Literal(0);  Z_Flags = Null Set
                 Set Assign(Z, W)
                 Release and Drop(Z)
              %finish
              S_Data = W_Data
              Drop(W)
              Dumped  = 1
              In Work = 1
           %finish
           Amap(S);  Load Pair(S, R8, X_A, R1)
           %if X_B == Nil %start
              Op = Set Bit
           %else
              Load Trio(X_B, R0, S, R8, X_A, R1)
              Release and Drop(X_B)
              Op = Set Bits
           %finish
           Prim(Op)
           Vmap(S, Sets);  S_Flags = S_Flags ! Work Set
           Release and Drop(X_A)
        %finish
        Dispose(X)
      %repeat
      Dump Set %if Dumped = 0
      S_Link == OldLink
      S_Oper  = OldOper
      Monitor(S, "Bset<-") %if Diag&MonOperand # 0
   %end

   %routine Compile In(%integer Stack it)
      %integer N
      %record(Stackfm)%name V, Set, C
      Set == Stack;  V == Set_Stack;  Stack == V_Stack
      Build Set(Set) %if Set_Members ## Nil
      Loadup(Set) %if Set_Oper # 0
      %if Set_Flags&Null Set # 0 %start
         %if Stackit # 0 %start
            C == Literal(0)             {false}
            C_Stack == Stack;  Stack == C
         %else
            Dump Word(16_E150 0000)     {CMPS _ R0, R0 = cc equal = false}
         %finish
         Release and Drop(Set);  Release and Drop(V)
         %return
      %finish
      %if (Iconst(V) %and 0 <= V_Disp <= 255) %start
         Advance(Set, Integers, (V_Disp>>5)<<2)
         Operate(ANDx, Set, Literal(1<<(V_Disp&31)))
         Test Zero(Set)
      %else
         Amap(Set)
         Load Pair(V, R1, Set, R2)
         Prim(SetIn)
      %finish
      Release and Drop Pair(Set, V)
      Stack True or False(NE) %if Stackit # 0
   %end

   %routine Add Member(%integer N)
      %record(Memberfm) Base
      %record(Memberfm)%name M, P
      %record(Stackfm)%name A, B == Nil
      %integer Items = 0
      A == Stack;  Stack == A_Stack
      %if N # 0 %start
         B == Stack;  Stack == B_Stack
         %if Iconst(A) %and Iconst(B) %and A_Disp < B_Disp %start {empty}
            Drop(A);  Drop(B);  %return
         %finish
      %finish
      M == NEW(Memberfm Type)
      M_A == A
      M_B == B
      Items = Stack_Members_Items %if Stack_Members ## NIL
      %if Iconst(A) %and (B == Nil %or Iconst(B)) %start
         M_Const = 1
         M_Link == Stack_Members
         Stack_Members == M
      %else
         M_Const = 0
         Base_Link == Stack_Members
         P == Base
         P == P_Link %while P_Link ## Nil %and P_Link_Const # 0
         M_Link == P_Link
         P_Link == M
         Stack_Members == Base_Link
      %finish
      Stack_Members_Items = Items+1
      Stack_Flags = Stack_Flags&(\Null Set)
   %end

   %routine Stack Data Size
      %integer T, N
      T = Pending;  Readsymbol(Pending)
      %if T = 0 %start
         T = Tag
         N = Var(T)_Format
         N = Var(-N)_Format %if N < 0 
      %else
         %if Undefined <= T <= Sets %then N = Type Size(T) -
                                    %else N = 0
         Fail("Unknown type") %if N = 0
      %finish
      Stack Integer(N)
   %end

   %routine Test for NIL
      %if Unassigned # 0 %start
         Stack_Flags = Stack_Flags!Known Ass
         Load(Stack, R1)
         Prim(TestNil)      {tests NIL, Unassigned & Disposed}
      %finish
   %end

   %routine Set Variant Count(%integer N)
      %record(stackfm)%name V == Copy(Stack), Count
      Vmap(V, Shorts)
      Count == Literal(N)
      Simple(Count, V)
      Release and Drop Pair(Count, V)
   %end


   %routine Test Variant Count(%integer N)
      %record(Stackfm)%name V == Copy(Stack), Count
      Count == Literal(N)
      Vmap(V, Shorts)
      Load Pair(V, R3, Count, R0)
      Prim(Test Variant)
      Release and Drop Pair(V, Count)
   %end

   %routine Check not long NEW
      %record(Stackfm)%name V == Copy(Stack)
      Amap(V);  Vmap(V, Shorts)
      Test Zero(V);  Invert = 0
      Prim(Test NEW)
      Release and Drop(V)
   %end

   %routine Check Dynamic Bounds
      %record(Stackfm)%name Lower, Upper
      Upper == Stack;  Lower == Upper_Stack;  Stack == Lower_Stack
      Load Trio(Stack, R1, Lower, R2, Upper, R3)
      Prim(Dynamic Range)
      Release and Drop Pair(Lower, Upper)
   %end

   %routine Localise
      {STACK Loc;  STACK size;  Stack Zero;  LOCALISE}
      {Loc is a pointer to an area containing SIZE bytes}
      {the area is copied into an anonymous local area and}
      {Zero is the displacement of AREA(first) from Area(0)}
      {i.e. Area(first) = Loc+Zero}
      {Loc is updated to point to this local area}
      %record(Stackfm)%name Loc, Size, Zero
      Zero  == Stack
      Size  == Zero_Stack
      Loc   == Size_Stack
      Stack == Loc_Stack
      Forget Destination(Loc)
      Amap(Loc)
      Load Trio(Size, R0, Zero, R1, Loc, R2)
      Prim(MakeLocal)
      Attributes = Attributes ! Attr Sp Unknown
      Release and Drop Pair(Size, Zero)
      Release and Drop(Loc)
   %end

   %routine End of Block
      %if Local # Base Local %start          {not first (dummy) call}
         %if Uncond Jump # Ca %and Avar_Type = Generals %and
                                   Avar_Flags&Prim Proc = 0 %start
            Return(Routine)
         %finish
      %finish
   %end

   %routine Process Include File
      Get String(Include File)
      Dir String(Dir Include, Include File)
   %end

   %switch C(0:255)

      At = 0
      Pending Auto = 0
      Old Frame = Frame
      %if Amode >= -1 %start                 {procedure definition, format start}
         Frame = 0                           {ready for first field}
         %if Amode >= 0 %start               {procedure def}
            Frame = 4                        {ready for first parameter}
            %if Avar_Flags&Xproc Spec # 0 %start  {previous external spec}
               Avar_Flags = Avar_Flags-Xproc Spec
               Avar_Disp  = 0
            %finish
            Avar_Disp = New Label %if Avar_Disp = 0 %and
                                  (Permrt # Ostate # External %or Amode = 0)
            %if Amode = 0 %start               {entry to block}
               %if Local > Base Local + Max Nesting %start
                  Fail("Subroutines nested too deeply")
               %finish
               Uncond Jump = -1;  Forget Everything
               Dir2(Dir Start Block, Avar_Disp);  Blocks = Blocks+1
               DIR String(-1, Internal Id)
               Fmark = Fmark+1;  Frame Use(Local) = Fmark
               %if DEBUG # 0 %start                                        {001}
                  Dir3(Dir DEBUG Start Proc,                               {001}
                                 0,           {type}                       {001}
                                 Current Line {source})                    {001}
               %finish                                                     {001}
            %finish
            %if Ostate = External %start
               %if Amode # 0 %start            {external spec}
                  Avar_Flags = Avar_Flags!Xproc Spec
                  Dump External(2_10, Avar)
               %else            {external definition}
                  Avar_Flags = Avar_Flags!Xproc Def
                  N = 2_11
                  N = 2_11 ! 1<<4 %if Avar_Flags&Keep Local # 0
                  Dump External(N, Avar)
                  Attributes = Attributes!Attr Xdef
                  %if Avar_Flags&Prim Proc # 0 %start
                     Attributes = Attributes!Attr Prim
                  %finish
               %finish
            %finish
         %else
            Dir2(Dir Record On, Avar_Area)
         %finish
      %finish

      Frame Extra = Frame
      Frame       = (Frame+Alignment)&Alignment Mask
      Frame Extra = Frame-Frame Extra
      Frame Base  = Frame
      MyMark    = Fmark
      Max Frame = 0
      Alt Align = \0
      Pending Known Register = 0
      Pending Auto = 0

      ->C('}') %if Code = 'H'                         {special for BEGIN}

      %cycle
         Code = Pending;  Readsymbol(Pending);  ->C(Code)

c('!'):  Operation(ORx);                                       %continue
c('"'):  Compare Double;                                       %continue
c('#'):  Jump Forward(Tag, NE);                                %continue
c('$'):  Define Var;                                           %continue
c('%'):  Operation(XORx);                                      %continue
c('&'):  Operation(ANDx);                                      %continue
c(''''): Input String Value;                                   %continue
c('('):  Jump Forward(Tag, LE);                                %continue
c(')'):  Jump Forward(Tag, GE);                                %continue
c('*'):  Operation(MULx);                                      %continue
c('+'):  Operation(ADDx);                                      %continue
c('-'):  Operation(SUBx);                                      %continue
c('.'):  Operation(CONCx);                                     %continue
c('/'):  Operation(DIVx);                                      %continue
c(':'):  Define Compiler Label(Tag);                           %continue
c(';'):  End of Block;                                 %exit
c('<'):  Jump Forward(Tag, LT);                                %continue
c('='):  Jump Forward(Tag, EQ);                                %continue
c('>'):  Jump Forward(Tag, GT);                                %continue
c('?'):  Compare Values;                                       %continue
c('@'):  Stack Var(Tag);                                       %continue
c('A'):  Init(Tag);                                            %continue
c('B'):  Jump Backward(Tag);                                   %continue
c('C'):  Compare Addresses;                                    %continue
c('D'):  Input Real Value;                                     %continue
c('E'):  Call(0);                                              %continue
c('F'):  Jump Forward(Tag, Always);                            %continue
c('G'):  Get String(Alias);                                    %continue
c('H'):  Compile Begin;                                        %continue
c('I'):  Select Input(Icode In2);  Readsymbol(Pending);        %continue
c('J'):  User Jump(Tag);                                       %continue
c('K'):  Return(False);                                        %continue
c('L'):  Define User Label(Tag);                               %continue
c('M'):  Return(Map);                                          %continue
c('N'):  Input Integer Value(0);                               %continue
c('O'):  Update Line(Tag);                                     %continue
c('P'):  Dump Byte(Popped Value&255);                              %continue
c('Q'):  Operation(RDIVx);                                     %continue
c('R'):  Return(Routine);                                      %continue
c('S'):  Assign(Equals);                                       %continue
c('T'):  Return(True);                                         %continue
c('U'):  Operate(NEGx, Stack, Nil);                            %continue
c('V'):  Return(Fn);                                           %continue
c('W'):  Switch Jump(Tag);                                     %continue
c('X'):  Operation(EXPx);                                      %continue
c('Z'):  Assign(EqualsEquals);                                 %continue
c('['):  Operation(LSHx);                                      %continue
c('\'):  Operate(NOTx, Stack, Nil);                            %continue
c(']'):  Operation(RSHx);                                      %continue
c('^'):  Stack_Format = -Tag;                                  %continue
c('_'):  Switch Label(Tag);                                    %continue
c('a'):  Array Access;                                         %continue
c('b'):  Constant Bounds;                                      %continue
c('c'):  Section = 1;  Get String(Section Id);         %exit
c('d'):  D = Tag;  N = Tag;  Dimension(D, N);                  %continue
c('e'):  Signal Event(Tag);                                    %continue
c('f'):  Compile For(Tag);                                     %continue
c('g'):  Test for NIL;                                         %continue
c('h'):  Special Call(Tag);                                    %continue
c('i'):  Array Index;                                          %continue
c('j'):  Assign(Jam);                                          %continue
c('k'):  Jump Forward(Tag, FF);                                %continue
c('l'):  Language Flags = Tag;                                 %continue
c('m'):  Do(Monitor Id, Monitor Ep, 0);                        %continue
c('n'):  Select(Tag);                                          %continue
c('o'):  Event Trap(Tag);                                      %continue
c('p'):  AssignParameter;                                      %continue
c('q'):  Process Include File;                                 %continue
c('r'):  Resolve(Tag);                                         %continue
c('s'):  To Store(Tag);                                        %continue
c('t'):  Jump Forward(Tag, TT);                                %continue
c('u'):  Aop;                                                  %continue
c('v'):  Operate(ABSx, Stack, Nil);                            %continue
c('w'):  Machine Code;  Forget Everything;                     %continue
c('x'):  Operation(REXPx);                                     %continue
c('y'):  Set CD(Tag, Diag);                                    %continue
c('z'):  Set CD(Tag, Control);                                 %continue
c('{'):  Assemble(DefV,
                  Blocktype,
                  Vars,
                  Local+1,
                  Parameter Mode, Attributes)
            %continue

c('}'):  %exit %if Finish Params
         Do("3L___stack_check", Stack Check, 0) %if Interface_Options&LL Stack # 0
         %continue
c('~'):  N = Pending;  Readsymbol(Pending)
         %exit %if Alternate Format(N);                      %continue

   {************ Extra Items **************}

c(128+'"'):  Unsigned = 10;  Stack Condition;                %continue
c(128+'?'):  Unsigned = 10;  Compare Values;                 %continue
c(128+','):  Max Frame = Frame %if Frame > Max Frame
             Frame = Frame Base;                             %continue
c(128+'0'):  N = Tag;  {but no operation}                    %continue
c(128+'1'):  Add Member(0);                                  %continue
c(128+'2'):  Add Member(1);                                  %continue
c(128+'3'):  Set Variant Count(Tag);                         %continue
c(128+'4'):  Test Variant Count(Tag);                        %continue
c(128+'5'):  Check not long NEW;                             %continue
c(128+'6'):  Check Dynamic Bounds;                           %continue

c(128+'/'):  Operation(UDIVx);                               %continue
c(128+'|'):  Operation(UREMx);                               %continue
c(128+'@'):  Decode(0, -1) %if Diag&Mon Code # 0
             Current Line = Tag;                             %continue
c(128+'A'):  Amap(Stack);                                    %continue
c(128+'B'):  %if Pending = 't' %then Pending = '#' -
                               %else Pending = '='
             Test Zero(Stack);  Pop Release and Drop;        %continue
c(128+'C'):  Unsigned = 0;  Stack Condition;                 %continue
c(128+'D'):  Duplicate;                                      %continue
c(128+'E'):  Loadup(Stack) %unless Stack_Form = Address -
                              %and Locked(Stack_Base)   -
                              %and Stack_Record == Nil  -
                              %and Stack_Index  == Nil;      %continue
c(128+'F'):  Stack_Format = -Tag;                            %continue
c(128+'I'):  Compile In(1);                                  %continue
c(128+'L'):  Localise;                                       %continue
c(128+'M'):  Operation(MODx);                                %continue
c(128+'N'):  Operation(REMx);                                %continue
C(128+'O'):  Apply Round(Stack);                             %continue
c(128+'P'):  Pop Release and Drop;                           %continue
c(128+'R'):  Define Range;                                   %continue
c(128+'S'):  Swop;                                           %continue
c(128+'T'):  Apply Trunc(Stack);                             %continue
c(128+'U'):  Use With(Tag);                                  %continue
c(128+'V'):  Vmap(Stack, Tag);                               %continue
c(128+'W'):  Stack Work Variable;                            %continue
C(128+'X'):  Loadup(Stack) %unless Stack_Type = Lreals;      %continue
c(128+'Z'):  Stack Integer(0);  Stack_Type = Sets
                                Stack_Flags = Null Set;      %continue
c(128+'['):  Claim With(Tag);                                %continue
c(128+']'):  Release With(Tag);                              %continue
c(128+'b'):  Input Integer Value(1);                         %continue
c(128+'c'):  General Compare;                                %continue
c(128+'e'):  N = Stack_Type ; Amap(Stack)
             Loadup(Stack) %unless Stack_Form = Address -
                              %and Locked(Stack_Base)   -
                              %and Stack_Index  == Nil  -
                              %and Stack_Record == Nil
             Vmap(Stack, N);                                 %continue
c(128+'f'):  For Range == Var(Tag);                          %continue
c(128+'g'):  Call(1);                                        %continue
c(128+'i'):  Compile In(0);                                  %continue
C(128+'n'):  Apply Int(Stack);                               %continue
c(128+'m'):  General Move;                                   %continue
c(128+'o'):  Owntype = Tag;                                  %continue
c(128+'p'):  Fmap(Tag);                                      %continue
c(128+'r'):  Test Range(Stack, Var(Tag));                    %continue
c(128+'s'):  Set Size or Type(1, Stack);                     %continue
c(128+'t'):  Set Size or Type(2, Stack);                     %continue
c(128+'v'):  Compare Values;  Prim(Test Variant);            %continue
c(128+'w'):  Apply Intpt(Stack);                             %continue
c(128+'z'):  Stack Data Size;                                %continue
c(128+'{'):  Nn = 0
             Assemble(AltV, -2, Vars, Local, -1, Nn)
             Alt Align = Alt Align&Falign;                   %continue
c(128+'}'):  Frame = Max Frame %if Max Frame > Frame
             Falign = Alt Align;                     %exit
      %repeat

      Global Attributes = Global Attributes! (Attributes&Attr GLOBALS)
      %if Amode&8 = 0 %start
         Attributes = Attributes!Attr Inner Uses %if Frame Use(Local) # MyMark
         %if DEBUG # 0 %start                                        {001}
            Dir2(Dir DEBUG End Proc, Current Line {source})          {001}
         %finish                                                     {001}
         Dir1(Dir End Block)
            Dump Encoded(Frame&Alignment Mask-Aframe)
            Dump Encoded(Code Base)
            Dump Encoded(Parameter Frame)
            Dump Encoded(Parameter Regs)
            Dump Encoded(Display Vector(Local))
            Dump Encoded(Local Display)
            Dump Encoded(Array Base)
            Dump Encoded(Attributes)
            Dump Encoded(Entry Mask)
            Dump Encoded(Event Bits&16_FFFF)
            Dump Encoded(Event Label)
            Dump Encoded(Event Body)
         Forget Everything
         Avar_Flags = Avar_Flags!Open
      %finish
      Terminate Block
      Display Vector(Local+1) = 0 %unless Local = Display Limit
      Danger Level = No Danger %if Danger Level = Local
      Pending Known Register = 0
      Pending Auto = 0
      Last Work = Work Base
      %return
C(*): Fail("Code ".Itos(Code, 0))
%end

{Initialisation}

   Activity(Sp) = -1       {lock the stack pointer}
   Activity(Fp) = -1       {lock the frame pointer}
   Activity(Sb) = -1       {lock the static base}

   Compiling Prim = Interface_Prim
   Unassigned     = Interface_Options&LL Assigned
   Debug          = Interface_Options&LL Debug                    {001}
   Own Base       = 16 %if Unassigned # 0

   Pvar(J)_P  == Nil %for J = 0, 1, Var Top
!0.9!   Ilabels(J) == NIL %for J = 0, 1, Max Label>>8
{0.9}   Ilabels(J)_Label == NIL %for J = 0, 1, Max Label>>8

   Select Input(Icode In);  Readsymbol(Pending)
   Var(0) = 0
   Default Value = 0            {*****make this unassigned later*****}
   Value = Default Value

   %routine Initialise(%record(Stackfm)%name V, %integer Base, Form)
      V = 0
      V_Base  = Base
      V_Type  = Integers
      V_Form  = Form
      V_Flags = Known Ass
   %end

   Initialise(Ua Pat,   Sb, Direct)
   Initialise(Zero,      0, Address)
   Initialise(One,       0, Address);      One_Disp = 1
   Initialise(SpV,      Sp, Address)

   %begin
      %integer J
      %record(Stackfm)%name R
      %for J = R0, 1, AnyF %cycle
         R == RegV(J)
         R = 0
         R_Base   = J
         R_Type   = Integers
         R_Form   = Address
         R_Format = Wordlength
         %if J >= F0 %start
            R_Type   = Lreals
            R_Format = Wordlength*2
         %finish
      %repeat
   %end

   Knowing == Nil
   Kasl    == Nil

   Select Output(Directives Out)
   Parms = Max Vars             {leaving Var(Max Vars) free}
   Constant Base = 0
   Free Label    = 0
   Section       = 0
   Assemble(Var(0), -16, 0, Base Local, 0, J)           {Var(0) is a dummy}

   Dump Encoded(Entry Point)
   Dump Encoded(Control)
   Dump Encoded(Min SB)

   Interface_Ref Count         = Refs
   Interface_Def Count         = Free Label
   Interface_Block Count       = Blocks
   Interface_External Count    = External No
   Interface_Global Size       = Own Base
   Interface_Global Array Size = Own Array Base
   Interface_Constant Size     = Constant Base

   %begin                              {get rid of heap objects}
      %routine Monitor(%string(255) Text)
         Select Output(Report)
         Printstring(Text);  Newline
      %end


      %record(Vvfm)%name V
      Monitor("Dispose Vars") %if Diag&MonLine # 0
      %while Var List ## NIL %cycle
         V == Var List;  Var List == Var List_Link
         DISPOSE(V)
      %repeat

      %record(Knowfm)%name K
      Monitor("Dispose Kasl") %if Diag&MonLine # 0
      %while Kasl ## Nil %cycle
         K == Kasl;  Kasl == Kasl_Link
         DISPOSE(K)
      %repeat

      %record(Ilabelfm)%name I
      Monitor("Dispose Labels") %if Diag&MonLine # 0
      %while Ilabel List ## NIL %cycle
         I == Ilabel List;  Ilabel List == I_Link
         DISPOSE(I)
      %repeat

      %record(WorkVfm)%name W1, W2 == Work List_Link
      Monitor("Dispose Work") %if Diag&MonLine # 0
      %while W2 ## NIL %cycle
         W1 == W2;  W2 == W2_Link
         DISPOSE(W1)
      %repeat
      Monitor("Disposed") %if Diag&MonLine # 0
   %end

%end

%endoffile