Edinburgh IMP77 Compiler - Version 8.4

    1  ! Some instances of the following records failed to identify fields:  Q_ V_ S_ AVAR_ B_ C_ W_ F_ R_ CHAIN_ TARGET_ L_
    2  
    3                  {###################################}
    4                  {#       Copyright (C) 1988        #}
    5                  {#           3L Limited            #}
    6                  {#                                 #}
    7                  {#       All rights reserved       #}
    8                  {###################################}
    9  
   10                         {Pass 2 for ARM IMP}
   11  
   12  %externalstring(7) P2 Version = "004"
   13  
   14  ! To Do:
   15  !
   16  
   17  !Revision history:
   18  !
   19  ! 004   7-Sep-88 PSR Made DALLOC forget Sp and
   20  !                    made FORGET forget locked regs {C-136}
   21  ! 003  22-Jun-88 PSR Changes to compile native on A310
   22  !                    Made diag string 127 instead of 31
   23  ! 002  23-Feb-88 PSR Changed to ARM calling stack frame
   24  ! 001   4-FEB-88 PSR Started additions for ACORN DEBUG
   25  !                  - Record diags dumped in reverse order (that of declaration)
   26  ! 0.9  15-Jan-88 PSR Removed the %name %array ILABELS by means of
   27  !                    another recordformat.
   28  !       ******* release 1.2 sent to Acorn & Validated *******
   29  !       2-Nov-87 PSR Put FORGET DESTINATION in JUMP BACKWARDS to permit
   30  !                    unassigned checking of control
   31  !                    catching unassigned FOR control variables
   32  !                  - Made MULTIPLY call LOAD PROTECTED in case destination
   33  !                    register is already in use. (SCR/87/448)
   34  !       9-Oct-87 PSR Made R14 preferable when hazarding to prevent
   35  !                    corrupting a parameter (e.g. for REAL EXP). (SCR/87/449)
   36  !                  - Added check for "Subroutines nested too deeply" (SCR/87/447)
   37  ! 0.8   5-Oct-87 PSR Removed optimisation for C1*(V1+C2) :: overflow!
   38  !                  - Added check for the cases: (I<<n) + Real
   39  !                                          and: Real + (I<<n) (SCR/87/407)
   40  !                  - MULTIPLY was corrupting INVERTED as it used the COMPARE
   41  !                    mechanism to generate the in-line code for *. This
   42  !                    mis-compiled 0 >= A*B (SCR/87/409)
   43  !                  - Fixed OPERATE which was converting A<<C - D into
   44  !                    D - A<<C. It now uses RSB instead. (SCR/87/408)
   45  !                  - Corrected a problem in FLOAT which made -10 into -2.0
   46  !                    (SCR/87/411)
   47  !                  - Added explicit check for setting bit out of range in
   48  !                    BUILD SET. (SCR/87/423)
   49  ! 0.7  19-sep-87 PSR Corrected problem with hazard all after PASS PARAMETERS
   50  !                    corrupting one (or more) of the parameter registers
   51  !                    (SCR/87/392)
   52  !                  - Set comparison changed to fix miscompilation of
   53  !                    IF [] >= [something] which was returning a zero/non-zero
   54  !                    condition code but testing for  a >= or <= code (SCR/87/398)
   55  !                  - Added internally-generated NO-OP 128+'0' + <tag>
   56  !                  - made WORK AREAS an indefinitely expanding list. (SCR/87/400)
   57  !                  - Corrected bugs in ABS(ABS(X)), ABS(-X), and ABS(\X).
   58  !                    (SCR/87/401, SCR/87/422)
   59  ! 0.6  16-Sep-87 PSR Test version for BSI visit
   60  !                  - Made BUILD SET save & restore oper & link to fix
   61  !                    problems with S := [1..x]-[y]; (SCR/87/388)
   62  !                  - Set the WORK SET bit on the temp created by BUILD SET
   63  !                  - Problem with passing longreals as parameters. The LDM
   64  !                    in PPARAMS.INC was not preceded by the necessary HAZARDS
   65  !                  - ABS(X) used unsafe MOVS to set condition code,
   66  !                    would not work if CC already set incorrectly.
   67  ! 0.5   7-Aug-87 NPH [SCR/87/324] Set value to Default value in Update Line
   68  !
   69  ! 0.5   4-Aug-87 NPH [SCR/87/325] If saved, Wsp must be saved after a Dalloc
   70  !                    Quick soln : save it again if it has been saved.
   71  !
   72  !      30-Jul-87 PSR PESSIMISE got the wrong displacement when temps were
   73  !                    a long way away from FP
   74  !                    Was also a problem with STAB.
   75  !       8-Jul-87 PSR Forget destination not forgetting after R_a(n) = ...
   76  !                  - Stopped optimising X&255 -> byte load when checkable
   77  ! 0.4  24-Jun-87 PSR The event trap routine was forgetting everything
   78  !                    AFTER it had planted the LDR Wsp .... This was wrong
   79  !                    it the save area was too far away for a simple load.
   80  !                    This gave rise to an address error in Pascal Pass1 after
   81  !                    a *FATAL ERROR report.
   82  ! 0.3  14-Jun-87 PSR Fixed ALL CONST when first string isn't constant
   83  !                  - Fixed PRINTSTRING("")
   84  ! 0.2  28-Mar-86 PSR Tightened up setting condition-code values
   85  !                  - remembered ZERO after in-line loops
   86  !                  - added optimisation to remember constants after IF x=const
   87  !                  - improved handling of SHORTS (esp in S&16_FFFF)
   88  !                  - optimised X op Y shift Const, X shift const op Y
   89  !                  - corrected problem with OWNs living at 0(SB)
   90  !                  - corrected problem causing Record=0 to clear by bytes.
   91  ! 0.01 24-Mar-86 PSR Released to Acorn
   92  ! 0.01 27-Jan-86 PSR Cloned from SUN pass2 v0.39
   93  
   94  %owninteger   Diag         = 0,
   95+               Debug        = 0,        {#0 if -DEBUG specified}   {001}
   96+               Current Line = 0         {here to aid diagnostics}
   97  
   98  %constinteger MonCode    = 1<<0,
   99+               MonStack   = 1<<1,
  100+               MonReg     = 1<<2,
  101+               MonOperand = 1<<3,
  102+               MonOperate = 1<<4,
  103+               MonMove    = 1<<5,
  104+               MonLine    = 1<<6,
  105+               MonOpt     = 1<<7,
  106+               MonCond    = 1<<8,
  107+               MonBang    = 1<<9
  108  
  109  %constinteger       Infinity =  (-1)>>1,
  110+               Minus Infinity = \Infinity
  111  
  112  %constinteger Max Vars        =   2000,  Var Top       = Max Vars>>6,
  113+               Max Labels      =   8000,  Max Label     = Max Labels!255,
  114+               Max Work Areas  =    500,  Max Work Area = Max Work Areas!15,
  115+               Max Nesting     =     17,
  116+               Max Bound       =      7,
  117+               Set Size        = 256//8
  118  
  119  {Types}
  120  
  121  %constinteger Undefined = 0,
  122+               Integers  = 1,
  123+               Shorts    = 2,
  124+               Halves    = 3,
  125+               Bytes     = 4,
  126+               Addrs     = 5,
  127+               Reals     = 6,
  128+               Lreals    = 7,
  129+               Strings   = 8,
  130+               Records   = 9,
  131+               Generals  = 10,
  132+               Labels    = 11,
  133+               Booleans  = 12,
  134+               Sets      = 13
  135  
  136  %constbytearray Internal Type(Undefined:Sets) =
  137+       Undefined, Integers, Shorts, Halves,   Bytes,  Addrs,
  138+       Reals,     Lreals,
  139+       Strings,   Records,  Generals, Labels, Bytes, Sets
  140  
  141  %conststring(7)%array TypeId(Undefined:Sets) =
  142+                "Unknown", "Integer", "Short  ", "Half   ", "Byte   ", "Addr   ",
  143+                "Real   ", "Lreal  ",
  144+                "String ", "Record ", "General", "Label  ", "Boolean", "Set    "
  145  
  146  %constbytearray Type Fmt (Undefined:Sets) = 0,4,2,2,1,4,4,8,0,0,0, 0,1,32
  147  %constbytearray Type Code(Undefined:Sets) = 0,1,6,6,5,1,2,8,3,4,0,10,0,0
  148  %constbytearray Type Size(Undefined:Sets) = 0,4,2,2,1,4,4,8,0,0,12,0,2,Set Size
  149  %constbytearray Ucheck   (Undefined:Sets) = 0,1,0,0,0,1,1,1,1,0,0,0,0,0
  150  
  151  !%from IMP %include Option3l, Stream3l, Spec3l, Interfac,
  152  !                      Comm23, Attr, Lflags
  153  
  154  %include "imp/option3l.inc"
 &1     %constinteger LL Trusted   = 1<< 0,
 &2   +               LL Trace     = 1<< 1,
 &3   +               LL Vars      = 1<< 2,
 &4   +               LL Lines     = 1<< 3,
 &5   +               LL Records   = 1<< 4,
 &6   +               LL Assigned  = 1<< 5,
 &7   +               LL Array     = 1<< 6,
 &8   +               LL Range     = 1<< 7,
 &9   +               LL Variants  = 1<< 8,
 &10  +               LL Knuth     = 1<< 9,
 &11  +               LL Warn      = 1<<10,
 &12  +               LL Mon       = 1<<11,
 &13  +               LL Reference = 1<<12,
 &14  +               LL Notify    = 1<<13,
 &15  +               LL Extend    = 1<<14,
 &16  +               LL Level0    = 1<<15,
 &17  +               LL Report    = 1<<16,
 &18  +               LL Decode    = 1<<17,
 &19  +               LL Predef    = 1<<18,
 &20  +               LL List      = 1<<19,
 &21  +               LL Stack     = 1<<20,
 &22  +               LL Anon      = 1<<21,
 &23  +               LL Brief     = 1<<22,
 &24  +               LL Debug     = 1<<23
 &25    %endoffile
  155  %include "imp/stream3l.inc"
 &1     %constinteger Source         = 1,  Predef In     = 2
 &2     
 &3     %constinteger Icode In       = 1,  Icode Out     = 1,
 &4   +               Icode In2      = 2,
 &5   +               Report         = 0,
 &6   +               Objectives Out = 1,  Objectives In = 1,  PrimObj In = 3,
 &7   +               Directives Out = 2,  Directives In = 2,  PrimDir In = 4,
 &8   +               Object Out     = 1,  Decode Out    = 3,
 &9   +               Listing        = 7
 &10    %endoffile
  156  %include "imp/spec3l.inc"
 &1     {Spec3L.INC}
 &2     %endoffile
  157  %include "imp/interfac.inc"
 &1     %recordformat CommFm( %c
 &2   +        %integer Language,
 &3   +                 Options,
 &4   +                 Specials,
 &5   +                 Prim,
 &6   +                 Statements,
 &7   +                 Faults,
 &8   +                 Ref Count,         Prim Ref Count,
 &9   +                 Def Count,         Prim Def Count,
 &10  +                 Block Count,       Prim Block Count,
 &11  +                 External Count,    Prim External Count,
 &12  +                 Global Size,       Prim Global Size,
 &13  +                 Formats,           Prim Formats,
 &14  +                 Constant Size,     Prim Constant Size,
 &15  +                 Global Array Size,
 &16  +                 Total Items,
 &17  +                 Total Blocks,
 &18  +                 Total Formats,
 &19  +                 Total Externals,
 &20  +    %string(255) Source File,
 &21  +                 Module)
 &22    
 &23    %constinteger Special Main = 2_0001
 &24    %endoffile
  158  %include "imp/comm23.inc"
 &1     %constinteger Dir Start Block      = 1,
 &2   +               Dir Diag             = 2,
 &3   +               Dir Line             = 3,
 &4   +               Dir Include          = 4,
 &5   +               Dir Record On        = 5,
 &6   +               Dir Record Off       = 6,
 &7   +               Dir Slabel           = 7,
 &8   +               Dir Label            = 8,
 &9   +               Dir Mark User        = 9,
 &10  +               Dir Const Addr       = 10
 &11    
 &12    %constinteger Dir Const Load       = 11,
 &13  +               Dir Real Load        = 12,
 &14  +               Dir Spec Load        = 13,
 &15  +               Dir Branch           = 14,
 &16  +               Dir McLabel          = 15,
 &17  +               Dir Modify           = 16,
 &18  +               Dir Header           = 17,
 &19  +               Dir Thunk            = 18,
 &20  +               Dir xThunk           = 19,
 &21  +               Dir Call             = 20
 &22    
 &23    %constinteger Dir Ext              = 21,
 &24  +               Dir Xref             = 22,
 &25  +               Dir xCall            = 23,
 &26  +               Dir Assigned         = 24,
 &27  +               Dir Prim             = 25,
 &28  +               Dir Return           = 26,
 &29  +               Dir Area             = 27,
 &30  +               Dir Swdef            = 28,
 &31  +               Dir Sw Ref           = 29,
 &32  +               Dir Init             = 30
 &33    
 &34    %constinteger Dir Dump             = 31,
 &35  +               Dir End Block        = 32,
 &36  +               Dir Debug Array      = 33,
 &37  +               Dir Debug Var        = 34,
 &38  +               Dir Debug Start Proc = 35,
 &39  +               Dir Debug End Proc   = 36
 &40    
 &41    %constinteger Max Dir              = 36
 &42    %endoffile
  159  %include "imp/attr.inc"
 &1     %constinteger Attr Needs Display = 2_00 0000 0001,
 &2   +               Attr Inner Uses    = 2_00 0000 0010,
 &3   +               Attr Needs Gp      = 2_00 0000 0100,
 &4   +               Attr Prim          = 2_00 0000 1000,
 &5   +               Attr Xdef          = 2_00 0001 0000,
 &6   +               Attr Sp Unknown    = 2_00 0010 0000,
 &7   +               Attr Dynamic       = 2_00 0100 0000,
 &8   +               Attr Local Display = 2_00 1000 0000,
 &9   +               Attr Inherit       = 2_01 0000 0000,
 &10  +               Attr Globals       = 2_10 0000 0000
 &11    
 &12    %constinteger Attr Both          = 2_00 0000 0010
 &13    %endoffile
  160  %include "imp/lflags.inc"
 &1     {lflags}
 &2     
 &3     %constinteger Pascal Flag       = 2_0001,
 &4   +               Non Exact For     = 2_0010,
 &5   +               Undefined Control = 2_0100
 &6     %endoffile
  161  
  162  
  163  %include "opcodes.inc"
 &1     %constinteger Invert Cond = 16_E000 0000
 &2     
 &3     %constinteger Cond EQ = 16_0000 0000 !! Invert Cond,
 &4   +               Cond NE = 16_1000 0000 !! Invert Cond,
 &5   +               Cond CS = 16_2000 0000 !! Invert Cond,
 &6   +               Cond CC = 16_3000 0000 !! Invert Cond,
 &7   +               Cond MI = 16_4000 0000 !! Invert Cond,
 &8   +               Cond PL = 16_5000 0000 !! Invert Cond,
 &9   +               Cond VS = 16_6000 0000 !! Invert Cond,
 &10  +               Cond VC = 16_7000 0000 !! Invert Cond,
 &11  +               Cond HI = 16_8000 0000 !! Invert Cond,
 &12  +               Cond LS = 16_9000 0000 !! Invert Cond,
 &13  +               Cond GE = 16_A000 0000 !! Invert Cond,
 &14  +               Cond LT = 16_B000 0000 !! Invert Cond,
 &15  +               Cond GT = 16_C000 0000 !! Invert Cond,
 &16  +               Cond LE = 16_D000 0000 !! Invert Cond,
 &17  +               Cond AL = 16_E000 0000 !! Invert Cond,
 &18  +               Cond NV = 16_F000 0000 !! Invert Cond
 &19    
 &20    {The Invert Cond is to make ALWAYS default to 0 internally}
 &21    
 &22    %constinteger Post Indexed = 16_0100 0000,
 &23  +               Reg Index    = 16_0200 0000,
 &24  +               Write Back   = 1<<21,
 &25  +               Byte Op      = 1<<22,
 &26  +               Scc          = 1<<20
 &27    
 &28    %constinteger IA = 16_0080 0000,     {increment after}
 &29  +               IB = 16_0180 0000,     {increment before}
 &30  +               DA = 16_0000 0000,     {decrement after}
 &31  +               DB = 16_0100 0000      {decrement before}
 &32    
 &33    %constinteger Logical Left     = 2_000<<4,
 &34  +               Logical Right    = 2_010<<4,
 &35  +               Arithmetic Right = 2_100<<4,
 &36  +               Rotate Right     = 2_110<<4
 &37    
 &38    %constinteger Logical Left R     = 2_1001<<4,
 &39  +               Logical Right R    = 2_1011<<4,
 &40  +               Arithmetic Right R = 2_1101<<4,
 &41  +               Rotate Right R     = 2_1111<<4
 &42    
 &43    %constinteger ADD = 16_4 << 21,
 &44  +               ADC = 16_5 << 21,
 &45  +               SUB = 16_2 << 21,
 &46  +               SBC = 16_6 << 21,
 &47  +               RSB = 16_3 << 21,
 &48  +               RSC = 16_7 << 21,
 &49  +               CMP = 16_A << 21 ! Scc,
 &50  +               CMN = 16_B << 21 ! Scc,
 &51  +               AND = 16_0 << 21,
 &52  +               EOR = 16_1 << 21,
 &53  +               ORR = 16_C << 21,
 &54  +               BIC = 16_E << 21,
 &55  +               TST = 16_8 << 21 ! Scc,
 &56  +               TEQ = 16_9 << 21 ! Scc,
 &57  +               MOV = 16_D << 21,
 &58  +               MVN = 16_F << 21
 &59    
 &60    %constinteger LDR = 16_0410 0000,
 &61  +               STR = 16_0400 0000
 &62    
 &63    %constinteger SWI = 16_0F00 0000
 &64    
 &65    %constinteger LDM = 16_0810 0000,
 &66  +               STM = 16_0800 0000
 &67    
 &68    %constinteger B   = 16_0A00 0000,
 &69  +               BL  = 16_0B00 0000
 &70    
 &71    {Floating-point ops}
 &72    
 &73    %constinteger LDFD = 2_ 00001100 0 0 0 1 0000 1000 0001 00000000,
 &74  +               LDFS = 2_ 00001100 0 0 0 1 0000 0000 0001 00000000,
 &75  +               STFD = 2_ 00001100 0 0 0 0 0000 1000 0001 00000000,
 &76  +               STFS = 2_ 00001100 0 0 0 0 0000 0000 0001 00000000
 &77    
 &78    %constinteger FLT = 2_ 00001110 000 0    1000 0000 0001 0001 0000,
 &79  +               FIX = 2_ 00001110 000 1    1000 0000 0001 0001 0000
 &80    
 &81    %constinteger CMF = 2_ 00001110 100 1 0000 1111 0001 0001 0000,
 &82  +               CNF = 2_ 00001110 101 1 0000 1111 0001 0001 0000
 &83    
 &84    %constinteger Small Constant = 8
 &85    
 &86    !These are the extended-mode functions
 &87    !%constinteger ADF = 2_ 00001110 0000 1000 0000 0001 0000 0000,
 &88    !              MUF = 2_ 00001110 0001 1000 0000 0001 0000 0000,
 &89    !              SUF = 2_ 00001110 0010 1000 0000 0001 0000 0000,
 &90    !              RSF = 2_ 00001110 0011 1000 0000 0001 0000 0000,
 &91    !              DVF = 2_ 00001110 0100 1000 0000 0001 0000 0000,
 &92    !              RDF = 2_ 00001110 0101 1000 0000 0001 0000 0000,
 &93    !              POW = 2_ 00001110 0110 1000 0000 0001 0000 0000,
 &94    !              RPW = 2_ 00001110 0111 1000 0000 0001 0000 0000,
 &95    !              RMF = 2_ 00001110 1000 1000 0000 0001 0000 0000,
 &96    !              POL = 2_ 00001110 1100 1000 0000 0001 0000 0000,
 &97    !              MVF = 2_ 00001110 0000 1000 1000 0001 0000 0000,
 &98    !              MNF = 2_ 00001110 0001 1000 1000 0001 0000 0000,
 &99    !              ABS = 2_ 00001110 0010 1000 1000 0001 0000 0000,
 &100   !              SQT = 2_ 00001110 0100 1000 1000 0001 0000 0000,
 &101   !              LOG = 2_ 00001110 0101 1000 1000 0001 0000 0000,
 &102   !              LGN = 2_ 00001110 0110 1000 1000 0001 0000 0000,
 &103   !              EXP = 2_ 00001110 0111 1000 1000 0001 0000 0000,
 &104   !              SIN = 2_ 00001110 1000 1000 1000 0001 0000 0000,
 &105   !              COS = 2_ 00001110 1001 1000 1000 0001 0000 0000,
 &106   !              TAN = 2_ 00001110 1010 1000 1000 0001 0000 0000,
 &107   !              ASN = 2_ 00001110 1011 1000 1000 0001 0000 0000,
 &108   !              ACS = 2_ 00001110 1100 1000 1000 0001 0000 0000,
 &109   !              ATN = 2_ 00001110 1101 1000 1000 0001 0000 0000,
 &110   !              FML = 2_ 00001110 1001 0000 0000 0001 1000 0000,
 &111   !              FDV = 2_ 00001110 1010 0000 0000 0001 1000 0000,
 &112   !              FRD = 2_ 00001110 1011 0000 0000 0001 1000 0000,
 &113   !              RND = 2_ 00001110 0011 0000 1000 0001 1000 0000
 &114   !
 &115   !These are the double-precision functions
 &116   %constinteger ADF = 2_ 00001110 0000 0000 0000 0001 1000 0000,
 &117 +               MUF = 2_ 00001110 0001 0000 0000 0001 1000 0000,
 &118 +               SUF = 2_ 00001110 0010 0000 0000 0001 1000 0000,
 &119 +               RSF = 2_ 00001110 0011 0000 0000 0001 1000 0000,
 &120 +               DVF = 2_ 00001110 0100 0000 0000 0001 1000 0000,
 &121 +               RDF = 2_ 00001110 0101 0000 0000 0001 1000 0000,
 &122 +               POW = 2_ 00001110 0110 0000 0000 0001 1000 0000,
 &123 +               RPW = 2_ 00001110 0111 0000 0000 0001 1000 0000,
 &124 +               RMF = 2_ 00001110 1000 0000 0000 0001 1000 0000,
 &125 +               POL = 2_ 00001110 1100 0000 0000 0001 1000 0000,
 &126 +               MVF = 2_ 00001110 0000 0000 1000 0001 1000 0000,
 &127 +               MNF = 2_ 00001110 0001 0000 1000 0001 1000 0000,
 &128 +               ABS = 2_ 00001110 0010 0000 1000 0001 1000 0000,
 &129 +               SQT = 2_ 00001110 0100 0000 1000 0001 1000 0000,
 &130 +               LOG = 2_ 00001110 0101 0000 1000 0001 1000 0000,
 &131 +               LGN = 2_ 00001110 0110 0000 1000 0001 1000 0000,
 &132 +               EXP = 2_ 00001110 0111 0000 1000 0001 1000 0000,
 &133 +               SIN = 2_ 00001110 1000 0000 1000 0001 1000 0000,
 &134 +               COS = 2_ 00001110 1001 0000 1000 0001 1000 0000,
 &135 +               TAN = 2_ 00001110 1010 0000 1000 0001 1000 0000,
 &136 +               ASN = 2_ 00001110 1011 0000 1000 0001 1000 0000,
 &137 +               ACS = 2_ 00001110 1100 0000 1000 0001 1000 0000,
 &138 +               ATN = 2_ 00001110 1101 0000 1000 0001 1000 0000,
 &139 +               FML = 2_ 00001110 1001 0000 0000 0001 1000 0000,
 &140 +               FDV = 2_ 00001110 1010 0000 0000 0001 1000 0000,
 &141 +               FRD = 2_ 00001110 1011 0000 0000 0001 1000 0000,
 &142 +               RND = 2_ 00001110 0011 0000 1000 0001 1000 0000
 &143   %endoffile
  164  
  165  %externalroutine PASS2(%record(Commfm)%name Interface)
  166     %constinteger Word Length    = 4,           {in bytes}
  167+                  Alignment      = 3,           {word alignment needed}
  168+                  Alignment Mask = \Alignment
  169  
  170     %externalroutinespec D68000(%integer Op, Ca)
  171     %externalroutinespec Dump Encoded(%integer N)
  172     %include "xspecs.inc"
 &1     {xspecs}
 &2     
 &3     %externalroutinespec Print Hex %alias "3L_IMP_PRINT_HEX"(%integer N, P)
 &4     %endoffile
  173  
  174     {Register info}
  175  
  176     {Integer activities are: 0 = free
  177     {                       -1 = locked
  178     {                       >0 = claimed that many times
  179     {NOTE: registers are only claimed by LOAD (or the load implied by OPTIMISE}
  180  
  181                {  Register         Alias}
  182    %constinteger  None =  0,
  183+                  R0   =  1,
  184+                  R1   =  2,
  185+                  R2   =  3,
  186+                  R3   =  4,
  187+                  R4   =  5,
  188+                  R5   =  6,
  189+                  R6   =  7,
  190+                  R7   =  8,
  191+                  R8   =  9,
  192+                  R9   = 10,       Sb = R9,
  193+                 R10   = 11,       Fp = R10,
  194+                 R11   = 12,       Ip = R11,
  195+                 R12   = 13,       Sp = R12,
  196+                 R13   = 14,       Sl = R13,
  197+                 R14   = 15,     Link = R14,
  198+                 R15   = 16,       Pc = R15,
  199+                 Any   = 17,
  200+                 F0    = 18,
  201+                 F1    = 19,
  202+                 F2    = 20,
  203+                 F3    = 21,
  204+                 F4    = 22,
  205+                 F5    = 23,
  206+                 F6    = 24,
  207+                 F7    = 25,
  208+                 AnyF  = 26
  209                { Register          Alias}
  210  
  211     %constbytearray Actual(0:AnyF) = 0,  0,  1,   2,   3,  4,   5,   6,   7,
  212+                                         8,  9,  10,  11, 12,  13,  14,  15, 0,
  213+                                         0,  1,   2,   3,  4,   5,   6,   7, 0
  214  
  215  
  216     %conststring(3)%array RegId(0:AnyF) = "",
  217+               "R0 ", "R1 ", "R2 ", "R3 ", "R4 ", "R5 ", "R6 ", "R7 ",
  218+               "R8 ", "R9 ", "R10", "R11", "R12", "R13", "R14", "R15", "R? ",
  219+               "F0 ", "F1 ", "F2 ", "F3 ", "F4 ", "F5 ", "F6 ", "F7 ", "F? "
  220  
  221     %constbytearray Rtype(0:AnyF) = Undefined, Integers(17), Lreals(9)
  222  
  223     %recordformat Boundfm(%integer Lower, Upper, Mult)
  224     %recordformat Afm(%integer Dimension,
  225+                               Total Size,
  226+                               Zero Displacement,
  227+                               DV,
  228+                               Local Frame,
  229+                               Base,
  230+        %record(Boundfm)%array Bound(1:Max Bound))
  231  
  232     %constrecord(Afm)%name A type == 0             {for NEW}
  233  
  234     %recordformat Varfm(%integer Flags,
  235+                        %byte Base, Prim,
  236+                     %byte  Type, Form,
  237+                     (%longreal Rvar %or
  238+                      %integer Disp, (%integer Extra %or %record(Afm)%name Adata)),
  239+                     (%integer Format %or %integer Scale),
  240+                     %integer Area)
  241  
  242  
  243     %recordformatspec Stackfm
  244     %recordformat Olfm(%integer  Oper, %record(Stackfm)%name Link)
  245     %recordformat  Xfm(%integer Xsize, %record(Stackfm)%name Index)
  246  
  247     %recordformat Datafm( %c
  248+            %record(Varfm)    V,
  249+            %integer Varno,
  250+            %record(Varfm)%name Fv,
  251+            (%integer Bias %or %byte Reg, Label),
  252+            %record(Stackfm)%name  Params, Record,
  253+            (%integer Oper, %record(Stackfm)%name Link %or %record(Olfm) Oplink),
  254+            (%integer Xsize, %record(Stackfm)%name Index %or %record(Xfm) X))
  255  
  256     %recordformat Memberfm(%integer Const, Items,
  257+                           %record(Stackfm)%name A, B,
  258+                           %record(Memberfm)%name Link)
  259  
  260     %constrecord(Memberfm)%name Memberfm Type == 0
  261  
  262     %recordformat Stackfm( %c
  263+       %record(Varfm)     V                   %or
  264+       %record(Datafm)    Data                %or
  265+       %integer Flags,
  266+       %byte Base, Prim,
  267+       %byte  Type, Form,
  268+       (%longreal Rval %or %integer Rhigh, Rlow %c
  269+         %or (%integer Disp, (%integer Extra %or %record(Afm)%name Adata)),
  270+       (%integer Format %or %integer Scale),
  271+       %integer Area,
  272+       %integer Varno,
  273+       (%record(Varfm)%name Fv %or %record(Memberfm)%name Members),
  274+       (%integer Bias %or %byte Reg, Label),
  275+       %record(Stackfm)%name     Params, Record,
  276+       (%integer  Oper, %record(Stackfm)%name Link  %or %record(Olfm) Oplink),
  277+       (%integer Xsize, %record(Stackfm)%name Index %or %record(Xfm) X)),
  278+       %record(Stackfm)%name          Using, Stack)
  279  
  280     %constrecord(Stackfm)%name Stackfm Type == 0
  281  
  282     %recordformat Withfm(%integer Key, %record(Datafm) Data,
  283+                         %record(Withfm)%name Link)
  284     %constrecord(Withfm)%name Withfm Type == 0
  285  
  286     %recordformat Workfm(%integer Size, Displacement, Validity)
  287     %recordformat WorkVfm(%record(WorkVfm)%name Link,
  288+                          %record(Workfm)%array W(0:30))
  289     %constrecord(WorkVfm)%name WorkVfmType == 0
  290     %record(WorkVfm) Work List = 0
  291     %integer Work Validity = 1, Last Work = -1
  292  
  293     {Flag bits}
  294  
  295     %constinteger  By Ref      = 1<< 0,            {in FLAGS}
  296+                   Array       = 1<< 1,
  297+                   Parameter   = 1<< 2,            {procedure parameter}
  298+                   Defered     = 1<< 3,            {needs indirection}
  299+                   Hazarded    = 1<< 4,
  300+                   Static      = 1<< 5,
  301+                   Arrayname   = 1<< 6,
  302+                   Known Ass   = 1<< 7,            {cannot be unassigned}
  303+                   Prim Proc   = 1<< 8,
  304+                   Primitive   = 1<< 9,            {prim procedure}
  305+                   Xproc Spec  = 1<<10,            {external procedure}
  306+                   Closed      = 1<<11,            {cannot return}
  307+                   Internal    = 1<<12,            {can use JSB}
  308+                   Call it     = 1<<13,            {cannot use JSB}
  309+                   Null Set    = 1<<14,
  310+                   Keep Local  = 1<<15,
  311+                   Nasty Proc  = 1<<16,            {uses the environment}
  312+                   Awanted     = 1<<17,
  313+                   Work Set    = 1<<18,
  314+                   Answer      = 1<<19,
  315+                   Checkable   = 1<<20,
  316+                   Pred Call   = 1<<21,            {is a predicate}
  317+                   Stored With = 1<<22,
  318+                   Xdata Spec  = 1<<23,
  319+                   Xproc Def   = 1<<24
  320  
  321     %recordformat Forfm(%byte             Label,  Entry, Reg, CC,
  322+                        %integer Type,
  323+                        %integer          AS,
  324+                        %record(Datafm) Control, Final,
  325+                        %record(Forfm)%name Link)
  326     %constrecord(Forfm)%name ForfmType == 0
  327     %ownrecord  (Forfm)%name Fors      == 0
  328  
  329     %ownrecord(Stackfm)%name   Stack == 0
  330     %ownrecord(Stackfm)%name   Using == 0,
  331+                               Dasl  == 0
  332  
  333     %recordformat Valuefm(%longreal       Real       %or %c
  334+                          %integer        Integer    %or %c
  335+                          %string(255)    String     %or %c
  336+                          %bytearray      Fill(0:255))
  337  
  338     %ownrecord(Valuefm) Value         = 0,
  339+                        Default Value = 0
  340  
  341  
  342  {Internal operations}
  343  
  344     %constinteger  Real Shift = 21
  345  
  346     %constinteger  NOTx  =  1,                 {Integer operations}
  347+                   NEGx  =  2,
  348+                   ABSx  =  3,
  349+                   ADDx  =  4,
  350+                   SUBx  =  5,
  351+                   MULx  =  6,
  352+                   DIVx  =  7,
  353+                   EXPx  =  8,
  354+                   ANDx  =  9,
  355+                    ORx  = 10,
  356+                   XORx  = 11,
  357+                   BICx  = 12,
  358+                   ROTx  = 13,
  359+                   LSHx  = 14,
  360+                   RSHx  = 15,
  361+                   REMx  = 16,
  362+                   MODx  = 17,
  363+                   MULHx = 18,                 {special for halfword multiply}
  364+                   UDIVx = 19,                 {unsigned divide}
  365+                   UREMx = 20,                 {unsigned rem}
  366+                   EXTx  = 21,
  367+                  CONCx  = 22,
  368+                  RNEGx  = NEGx+Real Shift,    {floating-point operations}
  369+                  RABSx  = ABSx+Real Shift,
  370+                  RADDx  = ADDx+Real Shift,
  371+                  RSUBx  = SUBx+Real Shift,
  372+                  RMULx  = MULx+Real Shift,
  373+                  RDIVx  = DIVx+Real Shift,
  374+                  REXPx  = EXPx+Real Shift
  375  
  376  
  377     %conststring(4)%array OperId(NOTx:REXPx) =
  378+                  "not ", "neg ", "abs ",
  379+                  "add ", "sub ", "mul ", "div ", "exp ",
  380+                  "and ", "or  ", "xor ", "bic ", "rot ", "lsh ", "rsh ",
  381+                  "rem ", "mod ",
  382+                  "ext ", "mulh", "udiv", "urem", "conc",
  383+                  "negr", "absr",
  384+                  "addr", "subr", "mulr", "divr", "expr"
  385  
  386  {Oper flags}
  387  
  388     %constinteger Commutative = 1<<0,
  389+                  InPrim      = 1<<1,
  390+                  Easy        = 1<<2,
  391+                  Selfop      = 1<<3,
  392+                  Unary       = 1<<5,
  393+                  Incdec      = 1<<6,
  394+                  No Assoc    = 1<<7,
  395+                  Weak Assoc  = 1<<8,   Assoc Mask = No Assoc!Weak Assoc,
  396+                  Nullop      = 1<<9
  397  
  398     %constshortarray Oper Flags(NOTx:REXPx) =
  399+                   {NOTx}  Unary!Selfop,
  400+                   {NEGx}  Unary!Selfop,
  401+                   {ABSx}  Unary,
  402+                   {ADDx}  Commutative!Easy!Selfop!Nullop!Incdec,
  403+                   {SUBx}              Easy!Selfop!Nullop!Incdec,
  404+                   {MULx}  Commutative!Weak Assoc!Nullop,
  405+                   {DIVx}         No Assoc!Nullop,
  406+                   {EXPx}  InPrim!No Assoc!Nullop,
  407+                   {ANDx}  Weak Assoc!Easy!Nullop!Selfop!Commutative,
  408+                   {ORx}   Weak Assoc!Easy!Nullop!Selfop!Commutative,
  409+                   {XORx}  Weak Assoc!Easy!Nullop!Selfop!Commutative,
  410+                   {BICx}  Weak Assoc!Easy!Nullop!Selfop,
  411+                   {ROTx}    No Assoc!Nullop,
  412+                   {LSHx}    No Assoc!Nullop!Selfop,
  413+                   {RSHx}    No Assoc!Nullop!Selfop,
  414+                   {REMx}    No Assoc,
  415+                   {MODx}    No Assoc,
  416+                   {EXTx}    No Assoc,
  417+                   {MULHx}   No Assoc,
  418+                   {UDIVx}   No Assoc,
  419+                   {UREMx}   No Assoc,
  420+                   {CONCx}   No Assoc,
  421+                   {RNEGx}   No Assoc!Unary!Selfop,
  422+                   {RABSx}   No Assoc!Unary,
  423+                   {RADDx}   No Assoc!Commutative,
  424+                   {RSUBx}   No Assoc,
  425+                   {RMULx}   No Assoc!Commutative,
  426+                   {RDIVx}   No Assoc,
  427+                   {REXPx}   No Assoc!Inprim
  428  
  429     %constintegerarray Easy Op(ADDx:BICx) =
  430+                   {ADDx} ADD,
  431+                   {SUBx} SUB,
  432+                   {MULx}   0,
  433+                   {DIVx}   0,
  434+                   {EXPx}   0,
  435+                   {ANDx} AND,
  436+                   {ORx}  ORR,
  437+                   {XORx} EOR,
  438+                   {BICx} BIC
  439  
  440     %constintegerarray Null Value(ADDx:RSHx) =
  441+                   0, {ADDx}   0, {SUBx}   1, {MULx}
  442+                   1, {DIVx}   1, {EXPx}  -1, {ANDx}
  443+                   0, {ORx}    0, {XORx}   0, {BICx}  0, {ROTx}
  444+                   0, {LSHx}   0  {RSHx}
  445  
  446  {Condition codes}
  447  
  448     %constinteger  EQ = 1,   LT = 2,   GT = 4,   TT = 8,  Always = 7,
  449+                   NE = 6,   LE = 3,   GE = 5,   FF = 9,  Never  = 0
  450  
  451     %constbytearray Reverse(Never:FF) = Never,
  452+                                        EQ {EQ},  GT {LT},  GE {LE},
  453+                                        LT {GT},  LE {GE},  NE {NE},
  454+                                        Always,   TT {TT},  FF {FF}
  455  
  456     %constbytearray Negated(Never:FF) = Always,
  457+                                        NE {EQ},  GE {LT},  GT {LE},
  458+                                        LE {GT},  LT {GE},  EQ {NE},
  459+                                        Never,    FF {TT},  TT {FF}
  460  
  461  {Otypes}
  462  
  463     %constinteger  Own      = 1,        EqualsEquals =  1,
  464+                   Con      = 2,        Equals       =  0,
  465+                   External = 3,        Jam          = -1,
  466+                   System   = 4,
  467+                   Dynamic  = 5,
  468+                   Primrt   = 6,
  469+                   Permrt   = 7
  470  
  471  {Procedure end codes}
  472  
  473     %constinteger  Map     = -2,
  474+                   Fn      = -1,               {negative implies stacked result}
  475+                   Routine =  0,
  476+                   True    =  1,
  477+                   False   =  2
  478  
  479  
  480     %integer    J, NN
  481     %owninteger Code            = 0,            {current I-code symbol}
  482+                Pending         = 0,            {next I-code symbol}
  483+                Pending Tag     = 0,            {optimise 0<=N<=...}
  484+                Pending Lit     = 0,
  485+                Pending Auto N  = 0,
  486+                Pending Auto    = 0,
  487+                Pending Auto Ca = 0,
  488+                Language Flags  = 0,
  489+                Stack Check     = 0,            {entry for external}
  490+                Falign          = 0             {worst internal alignment}
  491  
  492     %owninteger Invert      = 0,
  493+                Unsigned    = 0,
  494+                Free Label
  495  
  496     %constinteger Defined    = 16_8000 0000,
  497+                  Label Mask = \Defined,
  498+                  Inverted   = 1
  499  
  500     %recordformat Knowfm(%byte                Ftype, Reg, Base, Oper,
  501+                         %integer             Disp, Area, Opnd, Extra,
  502+                         %record(Knowfm)%name Link)
  503     %constrecord(Knowfm)%name KnowfmType == 0
  504  
  505     %recordformat Labelfm(%integer Lab, %record(Knowfm)%name Env)
  506  
  507     %recordformat Ilabelfm(%record(Ilabelfm)%name Link,
  508+                           %record(Labelfm)%array Lab(0:255))
  509     %constrecord(Ilabelfm)%name Ilabelfm Type == 0
  510     %record(Ilabelfm)%name Ilabel List == NIL
  511  
  512  !0.9!   %record(Ilabelfm)%namearray Ilabels(0: Max Label>>8)
  513  {0.9}   %recordformat IlabelPfm(%record(Ilabelfm)%name Label)
  514  {0.9}   %record(IlabelPfm)%array Ilabels(0:Max Label>>8)
  515  
  516     %ownrecord(Knowfm)%name   Knowing            == 0,
  517+                              Kasl               == 0
  518     %ownintegerarray          Ktimes(0:AnyF)      = 0(*)
  519  
  520     %owninteger               Used Time = 0
  521     %ownintegerarray          Used(0:AnyF)      = 0(*)
  522     %ownintegerarray          Activity(0:AnyF)  = 0(*)
  523     %owninteger               Active Registers = 0
  524  
  525     %integer                  Pending Known Register = 0
  526     %record(Stackfm)          Pending Known
  527  
  528     %ownstring(127)         Alias               = "",      {003}
  529+                            Internal Id         = "",
  530+                            External Id         = "",
  531+                            Section  Id         = ""
  532  
  533     %owninteger             Decl Size,
  534+                            Vlb, Vub,
  535+                            Ostate,
  536+                            OwnType,
  537+                            OwnForm,
  538+                            Ownextra,
  539+                            Constant Type,
  540+                            Init Flag = 0
  541  
  542     %record(Varfm)%name     DefV
  543     %record(Varfm)          AltV
  544     %owninteger             Parms
  545     %owninteger             Section    = 0
  546  
  547     %owninteger   Control        = 0,  {Unass Check}
  548+                  Unassigned     = 0,  {#0 for unassigned checks}
  549+                  Compiling Prim = 0   {#0 when compiling PRIM file}
  550  
  551  {Forms}
  552  
  553     %constinteger Address  = 0,
  554+                  Direct   = Address+1,
  555+                  AutoI    = 2,               Memorable Limit = AutoI,
  556+                  AutoD    = 3,
  557+                  Proc     = 4,
  558+                  LabelX   = 5,
  559+                  Indirect = 15               {**only for VARs**}
  560  
  561     %conststring(6)%array FormId(Address:LabelX) = "addr", "value", "()+",
  562+                                                    "-()",  "proc",  "label"
  563  
  564  {Prim routines}
  565  
  566     %constinteger  Signal       =  1,        {%signal}
  567+                   Cscomp       =  2,        {compare string & constant}
  568+                   Sres         =  3,        {string resolution}
  569+                   Sw Jump      =  4,        {switch jump}
  570+                   Intexp       =  5,        {integer exponentiation}
  571+                   RealExp      =  6,        {real exponentiation}
  572+                   Genmove      =  7,        {general string move}
  573+                   Sconc        =  8,        {string concatenation}
  574+                   Scomp        =  9,        {string comparison}
  575+                   Sjam         = 10,        {string jam transfer, length known}
  576+                   SetIn        = 11,        {test for R0 IN (R3)}
  577+                   Resflop      = 12,        {string resolution fails}
  578+                   TestNil      = 13,        {Nil, Unassigned & Disposed}
  579+                   MakeLocal    = 14,        {copy array into local space}
  580+                   Aref         = 15,        {n-dim array reference}
  581+                   Dynamic Range= 16,        {Check R2 <= R1 <= R3}
  582+                   Dynamic N    = 17,        {n-dim array declaration}
  583+                   Frag1        = 18,        {assign resolution fragment 1}
  584+                   RtMonitor    = 19,        {invoke run-time monitor}
  585+                   Set Bit      = 20,        {bit -> 1 in set}
  586+                   Captest      = 21,        {test for capacity exceeded}
  587+                   Ass Test     = 22,        {unassigned test}
  588+                   Trace Line   = 23,        {line trace debugger}
  589+                   Frag2        = 24,        {assign resolution fragment 2}
  590+                   Clear Bit    = 25,        {bit -> 0 in set}
  591+                   Test New     = 26,        {fail if variant NEW}
  592+                   Nil Test     = 27,        {Test for NIL pointer}
  593+                   Set Bits     = 28,        {set multiple bits in SETs}
  594+                   Set Add      = 29,
  595+                   Set Sub      = 30,
  596+                   Set Inter    = 31,
  597+                   Set GE       = 32,
  598+                   Check Range  = 33,
  599+                   Test MOD     = 34,        {check for a MOD (<=0)}
  600+                   Clear Bits   = 35,        {clear multiple bits in set}
  601+                   Test Variant = 36,
  602+                   Prim Mul     = 37,
  603+                   Prim Div     = 38,
  604+                   Test Real    = 39,        {compare real with zero}
  605+                   Prim Compare = 40,
  606+                   Real Intpt   = 41,
  607+                   Modulus      = 42
  608  { Avoid "Program too complex" compiler failure }
  609  %const %integer   Dynamic 1    = 43,        {single-dimension dynamic array}
  610+                   Dynamic 2    = 44,        {two-dimensional dynamic array}
  611+                   Psymbol      = 45,        {printsymbol}
  612+                   Set Range    = 46,        {check set ranges}
  613+                   ReadCh       = 47,        {readsymbol in prim}
  614+                   NextCh       = 48,        {nextsymbol in prim}
  615+                   Prim Udiv    = 49,        {unsigned divide}
  616+                   Set Zero     = 50,        {test for null set}
  617+                   Set Equal    = 51,        {test for set equality}
  618+                   Real Int     = 52,        {int(F0) -> R0}
  619+                   Real Round   = 53,        {round(F0) -> R0}
  620+                   CallP        = 54,        {call proc parameter}
  621+                   Enter P      = 55,        {jump to procedure}
  622+                   Dalloc       = 56         {dynamic allocation & unassign}
  623  
  624     %constinteger Last Prim = 56
  625  
  626     %owninteger    Enter Proc = 0          {filled in on first use}
  627  
  628     %constintegerarray Corrupts(Signal:Last Prim) =
  629+              {FFFF FFFF A RRRR RRRR RRRR RRRR }
  630+              {7654 3210   FEDC BA98 7654 3210 }
  631+             2_0000 0000 0 0000 0000 0000 0000,        { 1:signal}
  632+             2_0000 0000 0 0000 0000 0000 0001,        { 2:cscomp}
  633+             2_0000 0000 0 0001 0001 1111 1111,        { 3:Sres}
  634+             2_0000 0000 0 0000 0000 0000 0000,        { 4:swjump}
  635+             2_0000 0000 0 0000 0000 0010 1111,        { 5:intexp}
  636+             2_0000 0011 0 0000 0000 0000 0001,        { 6:realexp}
  637+             2_0000 0000 0 0000 1111 1111 1111,        { 7:rtraceproc}
  638+             2_0000 0000 0 0000 0000 0011 1100,        { 8:Sconc}
  639+             2_0000 0000 0 0000 0000 0111 1110,        { 9:scomp}
  640+             2_0000 0000 0 0000 0000 0000 1111,        {10:sjam}
  641+             2_0000 0000 0 0000 0000 0000 1001,        {11:SetIn}
  642+             2_0000 0000 0 0000 0000 0000 0000,        {12:ResFlop}
  643+             2_0000 0000 0 0000 0000 0000 0111,        {13:sconc opt}
  644+             2_0000 0000 0 0000 0000 0000 1111,        {14:MakeLocal}
  645+             2_0000 0000 0 0000 0000 0000 0000,        {15:aref}
  646+             2_0000 0000 0 0000 0000 0000 0000,        {16:Dynamic Range}
  647+             2_0000 0000 0 0000 1000 1110 1111,        {17:dynamic n}
  648+             2_0000 0000 0 0000 0000 1000 0111,        {18:Frag1}
  649+             2_0000 0000 0 0000 0000 0000 0000,        {19:rtmonitor}
  650+             2_0000 0000 0 0000 0000 0001 1001,        {20:set bit}
  651+             2_0000 0000 0 0000 0000 0000 0000,        {21:captest}
  652+             2_0000 0000 0 0000 0000 0000 0000,        {22:asstest}
  653+             2_0000 0000 0 0000 1111 1111 1111,        {23:traceline}
  654+             2_0000 0000 0 0000 0000 0100 1101,        {24:Frag2}
  655+             2_0000 0000 0 0000 0000 0001 1001,        {25:Clear bit}
  656+             2_0000 0000 0 0000 0000 0000 0000,        {26:Test New}
  657+             2_0000 0000 0 0000 0000 0000 0000,        {27:Nil test}
  658+             2_0000 0000 0 0000 0000 0011 1010,        {28:Set Bits}
  659+             2_0000 0000 0 0000 1001 1111 1111,        {29:Set Add}
  660+             2_0000 0000 0 0000 1001 1111 1111,        {30:Set Sub}
  661+             2_0000 0000 0 0000 1001 1111 1111,        {31:Set Inter}
  662+             2_0000 0000 0 0000 1001 1111 1111,        {32:Set GE}
  663+             2_0000 0000 0 0000 0000 0000 0000,        {33:Check Range}
  664+             2_0000 0000 0 0000 0000 0000 0000,        {34:test mod}
  665+             2_0000 0000 0 0000 0000 0011 1010,        {35:Clear Bits}
  666+             2_0000 0000 0 0000 0000 0000 0000,        {36:Test Variant}
  667+             2_0000 0000 0 0000 0000 0000 0011,        {37:prim mul}
  668+             2_0000 0000 0 0000 0000 0011 1111,        {38:prim div}
  669+             2_0000 0000 0 0000 0000 0000 0000,        {39:test real}
  670+             2_0000 0000 0 0000 0000 0001 1111,        {40:primcomp}
  671+             2_0000 0010 0 0000 0000 0000 0001,        {41:intpt}
  672+             2_0000 0000 0 0000 0000 0011 1110,        {42:modulus}
  673+             2_0000 0000 0 0000 0001 1111 1111,        {43:dynamic 1}
  674+             2_0000 0000 0 0000 0000 1111 1111,        {44:dynamic 2}
  675+             2_0000 0000 0 0001 1111 1111 1101,        {45:Psymbol}
  676+             2_0000 0000 0 0000 0000 0011 1000,        {46:Set Range}
  677+             2_0000 0000 0 0000 0011 1111 1111,        {47:ReadCh}
  678+             2_0000 0000 0 0000 0011 1111 1111,        {48:NextCh}
  679+             2_0000 0000 0 0000 0000 0000 1111,        {49:prim udiv}
  680+             2_0000 0000 0 0000 0001 1111 1110,        {50:set zero}
  681+             2_0000 0000 0 0000 1001 1111 1111,        {51:set equal}
  682+             2_0000 0011 0 0000 0000 0000 0001,        {52:Real Int}
  683+             2_0000 0001 0 0000 0000 0000 0001,        {53:Real Round}
  684+             2_0000 0000 0 0000 0000 0000 0000,        {54:CallP}
  685+             2_0000 0000 0 0000 0000 0000 0000,        {55:EnterP}
  686+             2_0000 0000 0 0001 1000 0001 0000         {56:Dalloc}    {004}
  687  
  688     %constintegerarray Prim Parameter(Signal:Last Prim) =
  689+              {FFFF FFFF A RRRR RRRR RRRR RRRR }
  690+              {7654 3210   FEDC BA98 7654 3210 }
  691+             2_0000 0000 0 0000 0000 0000 0000,        { 1:signal}
  692+             2_0000 0000 0 0000 0000 0000 0110,        { 2:cscomp}
  693+             2_0000 0000 0 0001 1111 0001 1110,        { 3:Sres}
  694+             2_0000 0000 0 0000 0000 0000 0010,        { 4:swjump}
  695+             2_0000 0000 0 0000 0000 0000 0110,        { 5:intexp}
  696+             2_0000 0001 0 0000 0000 0000 0001,        { 6:realexp}
  697+             2_0000 0000 0 0000 0000 0000 0000,        { 7:traceproc}
  698+             2_0000 0000 0 0000 0000 0000 1100,        { 8:Sconc}
  699+             2_0000 0000 0 0000 0000 0000 0110,        { 9:scomp}
  700+             2_0000 0000 0 0000 0000 0000 0111,        {10:sjam}
  701+             2_0000 0000 0 0000 0000 0000 0110,        {11:SetIn}
  702+             2_0000 0000 0 0000 0000 0000 0000,        {12:ResFlop}
  703+             2_0000 0000 0 0000 0000 0000 0111,        {13:sconc opt}
  704+             2_0000 0000 0 0000 0000 0000 0111,        {14:MakeLocal}
  705+             2_0000 0000 0 0000 0000 0000 0000,        {15:aref}
  706+             2_0000 0000 0 0000 0000 0000 1110,        {16:Dynamic Range}
  707+             2_0000 0000 0 0000 1000 0000 0110,        {17:dynamic n}
  708+             2_0000 0000 0 0001 0000 1000 0110,        {18:Frag1}
  709+             2_0000 0000 0 0000 0000 0000 0000,        {19:rtmonitor}
  710+             2_0000 0000 0 0000 0001 0000 0010,        {20:set bit}
  711+             2_0000 0000 0 0000 0000 0000 0000,        {21:captest}
  712+             2_0000 0000 0 0000 0000 0000 0000,        {22:asstest}
  713+             2_0000 0000 0 0000 0000 0000 0000,        {23:traceline}
  714+             2_0000 0000 0 0001 0000 0100 1100,        {24:Frag2}
  715+             2_0000 0000 0 0000 0001 0000 0010,        {25:clear bit}
  716+             2_0000 0000 0 0000 0000 0000 0000,        {26:Test New}
  717+             2_0000 0000 0 0000 0000 0000 0010,        {27:Nil test}
  718+             2_0000 0000 0 0000 0001 0000 0011,        {28:Set Bits}
  719+             2_0000 0000 0 0000 1001 0000 0000,        {29:Set Add}
  720+             2_0000 0000 0 0000 1001 0000 0000,        {30:Set Sub}
  721+             2_0000 0000 0 0000 1001 0000 0000,        {31:Set Inter}
  722+             2_0000 0000 0 0000 1001 0000 0000,        {32:Set GE}
  723+             2_0000 0000 0 0000 0000 0000 1010,        {33:Check Range}
  724+             2_0000 0000 0 0000 0000 0000 0000,        {34:test mod}
  725+             2_0000 0000 0 0000 0001 0000 0011,        {35:Clear Bits}
  726+             2_0000 0000 0 0000 0000 0000 1010,        {36:Test Variant}
  727+             2_0000 0000 0 0000 0000 0000 0011,        {37:prim mul}
  728+             2_0000 0000 0 0000 0000 0000 0110,        {38:prim div}
  729+             2_0000 0000 0 0000 0000 0000 0000,        {39:test real}
  730+             2_0000 0000 0 0000 0000 0000 0111,        {40:primcomp}
  731+             2_0000 0000 0 0000 0000 0000 0011,        {41:intpt}
  732+             2_0000 0000 0 0000 0000 0000 0110,        {42:prim div}
  733+             2_0000 0000 0 0000 0000 0011 1000,        {43:dynamic 1}
  734+             2_0000 0000 0 0000 0001 1101 1000,        {44:dynamic 2}
  735+             2_0000 0000 0 0000 0000 0000 0010,        {45:Psymbol}
  736+             2_0000 0000 0 0000 0000 0000 0111,        {46:Set Range}
  737+             2_0000 0000 0 0000 0000 0000 0000,        {47:ReadCh}
  738+             2_0000 0000 0 0000 0000 0000 0000,        {48:NextCh}
  739+             2_0000 0000 0 0000 0000 0000 0110,        {49:prim udiv}
  740+             2_0000 0000 0 0000 0000 0000 0001,        {50:set zero}
  741+             2_0000 0000 0 0000 0000 0000 0011,        {51:set equal]
  742+             2_0000 0001 0 0000 0000 0000 0001,        {52:Real Int}
  743+             2_0000 0001 0 0000 0000 0000 0000,        {53:Real Round}
  744+             2_0000 0000 0 0000 0000 0000 0000,        {54:CallP}
  745+             2_0000 0000 0 0000 0000 0000 0000,        {55:EnterP}
  746+             2_0000 0000 0 0000 0000 0001 0000         {56:Dalloc}
  747  
  748  {File data}
  749  
  750     %constinteger Icode = 1
  751  
  752     %owninteger Last Dir = 0,
  753+                Refs     = 0,  Blocks = 0
  754  
  755  {Areas}
  756  
  757     %constinteger     Code Area = 0<<8,
  758+                       Own Area = 1<<8,
  759+                  Constant Area = 2<<8,
  760+                 Own Array Area = 3<<8
  761  
  762     {============================================================}
  763  
  764     %owninteger        Own Base =  0,            {current own area address}
  765+                       Min SB   =  0,            {backward offset into SB}
  766+                 Own Array Base =  0,
  767+                  Constant Base =  0,            {current constant area address}
  768+                   Current Area =  Code Area,    {currently selected area}
  769+                      Last Area =  0,
  770+                    External No =  0
  771  
  772     %constinteger Base Local = 128
  773  
  774     %ownintegerarray Frame Use(Base Local:Base Local+Max Nesting) = 0(*)
  775     %owninteger Fmark = 0
  776  
  777     %record(Stackfm)       Uapat, Zero, One, SpV
  778     %record(Stackfm)%array RegV(None:AnyF)
  779  
  780     %record(Varfm)%name     For Range == Nil    {## Nil if check required}
  781  
  782     %record(Stackfm)    C255 = 0;  C255_Disp = 255;  C255_Type = Integers
  783     %constinteger          No Danger = 16_7FFF          {>> than 128+depth}
  784     %owninteger            Jamit= 0, Entry Point = -1,
  785+                           Danger Level    = No Danger  {limit of normal globals}
  786  
  787     %string(127) Include File = ""
  788  
  789     %integer Dtype      {for remembering disag type on arrays}
  790  
  791     %recordformat Qfm(%integer Type, Size, Round, Bias, Dim, Format,
  792+                               Diags, Dtype, Dform, Ind,
  793+                      %record(Qfm)%name Pointed)
  794  
  795     %recordformat Diag Fm(%record(Diagfm)%name Link,
  796+                          %record(Varfm)%name  Var,
  797+                          %integer             X, Xtype,
  798+                                               Format,
  799+                                               Ext,
  800+                          %string(127)         Id)            {003}
  801  
  802     %constrecord(Diagfm)%name Diagfm Type == 0
  803     %record(Diagfm)%name Diag List == Nil
  804  
  805     %constinteger Display Limit = 128+17
  806     %ownshortarray Display Vector(128:Display Limit) = 0(*)
  807  
  808     %owninteger Cp = 0
  809     %bytearray Code Buffer(0:255)
  810  
  811     %recordformat Vvfm(%record(Vvfm)%name Link, %record(Varfm)%array V(0:63))
  812     %constrecord(Vvfm)%name VvfmType == 0
  813     %record(Vvfm)%name Var List == NIL
  814     %recordformat Pvfm(%record(Vvfm)%name P)
  815     %record(Pvfm)%array Pvar(0:Var Top)
  816  
  817     %record(Varfm)%map Var(%integer A)
  818        %record(Vvfm)%name V
  819        %record(Pvfm)%name X
  820        X == Pvar(A>>6)
  821        %if X_P == Nil %start
  822           V == NEW(VvfmType)
  823           V_Link == Var List;  Var List == V
  824           X_P == V
  825        %finish
  826        %result == X_P_V(A&63)
  827     %end
  828  
  829     %routine Flush Code
  830        %integer J
  831        %return %if Cp = 0
  832        Printsymbol(Dir Dump)
  833        Dump Encoded(Cp)
  834        Printsymbol(Code Buffer(J)) %for J = 1, 1, Cp
  835        Cp = 0
  836     %end
  837  
  838  %routine Assemble(%record(Varfm)%name Avar,
  839+                   %integer Amode, Vars, Local, Parameter List,
  840+                   %integername Global Attributes)
  841  {Amode = -16 - Initial call          }
  842  {         -2 - Alternate format start}
  843  {         -1 - Recordformat          }
  844  {          0 - Procedure             }
  845  {         >0 - Procedure spec        }
  846  %routinespec             Not in Yet
  847  %routinespec             Fail(%string(63) Why)
  848  %routinespec             Warn(%integer Fault, %string(63) What)
  849  %routinespec             Display(%record(Stackfm)%name V, %integer Bias)
  850  %routinespec             Monitor(%record(Stackfm)%name V, %string(127) Text)
  851  %predicatespec           Iconst(%record(Stackfm)%name V)
  852  %predicatespec           Iconst Item(%record(Stackfm)%name V)
  853  %predicatespec           Const(%record(Stackfm)%name V)
  854  %predicatespec           Same(%record(Stackfm)%name A, B)
  855  %predicatespec           InReg(%record(Stackfm)%name V)
  856  %predicatespec           Floating(%record(Stackfm)%name V)
  857  %integerfnspec           Power(%integer N)
  858  %integerfnspec           Item Size(%integer T)
  859  %record(Stackfm)%mapspec Register(%integer R)
  860  %routinespec             Claim(%integer Register)
  861  %routinespec             Release(%integer Register)
  862  %routinespec             Release and Drop(%record(Stackfm)%name V)
  863  %routinespec             Zap Index and Record(%record(Stackfm)%name V)
  864  %routinespec             Release and Drop Pair(%record(Stackfm)%name A, B)
  865  %routinespec             Hazard(%integer Register)
  866  %routinespec             Pessimise(%record(Stackfm)%name V)
  867  %routinespec             Forget(%integer Register)
  868  %routinespec             Forget Destination(%record(Stackfm)%name V)
  869  %routinespec             Forget Everything
  870  %routinespec             Remember(%integer Register, %record(Stackfm)%name V)
  871  %routinespec             Remember Zero(%integer Register)
  872  %routinespec             Optimise(%record(Stackfm)%name V, %integer Mode)
  873  
  874  %routinespec             Simplify(%record(Stackfm)%name V)
  875  %routinespec             Amap(%record(Stackfm)%name V)
  876  %routinespec             Vmap(%record(Stackfm)%name V, %integer Type)
  877  %routinespec             Make AutoI(%record(Stackfm)%name V, %integer Type)
  878  %routinespec             Advance(%record(Stackfm)%name V, %integer Type, By)
  879  %routinespec             Load(%record(Stackfm)%name V, %integer Register)
  880  %routinespec             Loadup(%record(Stackfm)%name V)
  881  %routinespec             Load Address(%record(Stackfm)%name V, %integer R)
  882  %routinespec             Loadup Address(%record(Stackfm)%name V)
  883  %routinespec             Load Pair(%record(Stackfm)%name A, %integer Ar,
  884+                                    %record(Stackfm)%name B, %integer Br)
  885  %routinespec             Load Trio(%record(Stackfm)%name A, %integer Ar,
  886+                                    %record(Stackfm)%name B, %integer Br,
  887+                                    %record(Stackfm)%name C, %integer Cr)
  888  %routinespec             Pop Stack(%integer Bytes)
  889  %routinespec             Load Protected(%record(Stackfm)%name V)
  890  %routinespec             Move(%record(Stackfm)%name From, To)
  891  %routinespec             Move Literal(%integer Lit, %record(Stackfm)%name V)
  892  %routinespec             Store(%record(Stackfm)%name From, To)
  893  %routinespec             Store Address(%record(Stackfm)%name From, To,
  894+                                        %integername Extra)
  895  %routinespec             Operate(%integer Op, %record(Stackfm)%name L, R)
  896  %routinespec             Compare(%record(Stackfm)%name L, R)
  897  %integerfnspec           New Label
  898  %routinespec             Jump To(%integer Internal Label, Cond Code)
  899  %routinespec             Define Label(%integer Internal Label)
  900  %routinespec             Test Zero(%record(Stackfm)%name V)
  901  %routinespec             Test Range(%record(Stackfm)%name V,
  902+                                     %record(Varfm)%name R)
  903  %routinespec             Clear Vars(%integer Limit)
  904  %routinespec             DIR String(%integer Op, %string(*)%name S)
  905  %routinespec             Float(%record(Stackfm)%name V, %integer R)
  906  %routinespec             Dump External(%integer C, %record(Varfm)%name V)
  907  %routinespec             Do(%string(31) Ident, %integername Ep, %integer Result)
  908  
  909  %integerfnspec           GPR
  910  %integerfnspec           FPR
  911  %integerfnspec           Select Best(%record(Stackfm)%name From, To, %integer D)
  912  %record(Stackfm)%mapspec Descriptor
  913  %record(Stackfm)%mapspec Temporary
  914  %routinespec             Drop(%record(Stackfm)%name V)
  915  %record(Stackfm)%mapspec Local Integer(%integer Disp)
  916  %record(Stackfm)%mapspec Literal(%integer N)
  917  %record(Stackfm)%mapspec Copy(%record(Stackfm)%name V)
  918  
  919  %integerfnspec           Tag
  920  %integerfnspec           Four Bytes
  921  
  922  %routinespec             Prim(%integer N)
  923  %routinespec             Dump Text(%integer Max)
  924  %routinespec             Pass Parameters(%record(Stackfm)%name V,
  925+                                          %integername X, %integer BaseReg)
  926  %routinespec             Assign(%integer How)
  927  %routinespec             String Assign(%record(Stackfm)%name From, To)
  928  %routinespec             Set Assign(%record(Stackfm)%name From, To)
  929  %routinespec             Evaluate String Expression(%record(Stackfm)%name V)
  930  %routinespec             Record Assign(%record(Stackfm)%name From, To)
  931  %record(Stackfm)%mapspec Claim Work Area(%integer Size, Type)
  932  %routinespec             Flush Diags
  933  %routinespec             Convert Format(%record(Stackfm)%name V, %integer Type)
  934  %routinespec             To Short Real(%record(Stackfm)%name V)
  935  %routinespec             Store Real Constant(%record(Stackfm)%name W)
  936  %routinespec             Build Set(%record(Stackfm)%name S)
  937  %routinespec             Drop Members(%record(Stackfm)%name S)
  938  
  939  %owninteger Frame           = 0,
  940+             Round           = 0
  941  %integer    Aframe          = 0,                {array extension to frame}
  942+             Parameter Frame = 0,
  943+             Parameter Regs  = 0,
  944+             String Result   = 0
  945  
  946  %integer    Block Type  = 0,
  947+             Code Base   = 0,
  948+             Uncond Jump = -1,
  949+             D,
  950+             N,
  951+             Parameter Mode,
  952+             VarBase   = Vars,
  953+             First Alt = Parms-1,
  954+             Frame Base,
  955+             Old Frame,
  956+             Alt Align,         {Worst alignment of record alternatives}
  957+             Frame Extra,       {putative padding at front of alternative}
  958+             Max Frame          {largest alternative so far}
  959  
  960  %integer    Assign Lock     = 1 {#0 to permit marking assigned permanently}
  961  
  962  %integer    Attributes      = 0,
  963+             At              = 0,
  964+             Entry Mask      = 0,
  965+             MyMark,
  966+             Open            = Closed,   {assume cannot return}
  967+             Event Label     = 0,
  968+             Event Body      = 0,
  969+             Event Bits      = 0,
  970+             Wsp Save        = 0,    {frame address of where SP is saved}
  971+             Danger Marker   = 0,    {=1 if the block is dangerous}
  972+             Local Display   = 0,    {#0 if in a dangerous block}
  973+             Jlab,
  974+             Array Base      = 0     {#0 if allocated}
  975  
  976     %integer Work Base = Last Work
  977  
  978  %integername Ca == Code Base      {current Address}
  979  
  980  %string(127) Proc Id = Internal Id                {003}
  981  
  982  %record(Withfm)%name Withs == Nil
  983  
  984  %conststring(255) Monitor Id = "3L___monitor"
  985  %owninteger       Monitor Ep = 0
  986  
  987  %routine Decode(%integer Word, At)
  988     %externalroutinespec D %alias "DECODE_ARM"(%integer W, A)
  989     Select Output(Report)
  990     D(Word, At)
  991     Select Output(Directives Out)
  992  %end
  993  
  994  %record(Stackfm)%map Display Info(%integer Base)
  995     %integer N
  996     %record(Stackfm)%name T
  997     %if Base < Danger Level %start               {the safe case}
  998        Frame Use(Base) = 0                       {show the level used}
  999        N = Display Vector(Base)
 1000        %if N = 0 %start
 1001           Min SB = Min SB-4;  N = Min SB
 1002           Display Vector(Base) = N
 1003        %finish
 1004        T == Literal(N)
 1005        T_Form  = Direct
 1006        T_Base  = Sb
 1007     %else                                        {the dangerous case - p-params}
 1008        T == Local Integer(Local Display+4*(Base-Danger Level))
 1009     %finish
 1010     Attributes = Attributes!Attr Needs Display ! Attr Needs Gp
 1011     T_Flags = T_Flags!Known Ass
 1012     %result == T
 1013  %end
 1014  
 1015  %routine BD(%integer Base, Disp)
 1016     Write(Disp, 1)
 1017     Printsymbol('(')
 1018     %if None <= Base <= AnyF %start
 1019        Printstring(Regid(Base))
 1020     %else
 1021        %if Base >= Base Local %start
 1022           %if Base = Local %start
 1023              Printstring("Fp")
 1024           %else
 1025              Printsymbol('L')
 1026              Base = Base-Base Local-1
 1027              Write(Base, 0)
 1028           %finish
 1029        %else
 1030           Write(Base, 0)
 1031        %finish
 1032     %finish
 1033     Printsymbol(')')
 1034  %end
 1035  
 1036  %routine Show(%integer N, %string(15) Text)
 1037     %if N # 0 %start
 1038        Space;  Printstring(Text)
 1039        Write(n, 1)
 1040     %finish
 1041  %end
 1042  
 1043  %routine Show Data(%record(Stackfm)%name V, %integer Left)
 1044     Spaces(Left);  Printstring(Typeid(V_Type))
 1045     Space;         Printstring(Formid(V_Form))
 1046     BD(V_Base, V_Disp)
 1047     Show(V_Format, "Fm:")
 1048     Show(V_Area,   "A:")
 1049     Show(V_Flags,  "Fl:")
 1050        PrintSymbol('R') %if V_Flags&By Ref     # 0
 1051        PrintSymbol('A') %if V_Flags&Array      # 0
 1052        PrintSymbol('N') %if V_Flags&Arrayname  # 0
 1053        PrintSymbol('P') %if V_Flags&Parameter  # 0
 1054        PrintSymbol('D') %if V_Flags&Defered    # 0
 1055        PrintSymbol('W') %if V_Flags&Awanted    # 0
 1056        PrintSymbol('S') %if V_Flags&Static     # 0
 1057        PrintSymbol('=') %if V_Flags&Known Ass  # 0
 1058        Printsymbol('H') %if V_Flags&Hazarded   # 0
 1059        Printsymbol('X') %if V_Flags&Xproc Spec      # 0
 1060        Printsymbol('n') %if V_Flags&Nasty Proc # 0
 1061        Printsymbol('C') %if V_Flags&Checkable  # 0
 1062     PrintSymbol('#') %and Write(V_Varno, 0) %if V_Varno # 0
 1063     %if V_Record ## Nil %start
 1064        Newline
 1065        Spaces(Left);  Printstring("  _:")
 1066        Display(V_Record, Left+4)
 1067     %finish
 1068     %if V_Index ## Nil %start
 1069        Newline
 1070        Write(V_Xsize, Left+2);  Printstring("i:")
 1071        Display(V_Index, Left+4)
 1072     %finish
 1073  %end
 1074  
 1075  %routine Display(%record(Stackfm)%name V, %integer Bias)
 1076     %if V == Nil %start
 1077        Printstring(" Nil");  Newline
 1078        %return
 1079     %finish
 1080     Show Data(V, Bias)
 1081     newline
 1082     %if V_Oper # 0 %start
 1083        Spaces(Bias-4);  Printstring(Operid(V_Oper))
 1084        Display(V_Link, Bias+4)
 1085     %finish
 1086  %end
 1087  
 1088  %routine Show Reg(%integer R)
 1089     %integer A
 1090     A = Activity(R)
 1091     Printstring(Regid(R))
 1092     %if A = 0 %start
 1093        Printstring(" unused")
 1094     %else %if A < 0
 1095        %if A = -1 %start
 1096           Printstring(" locked")
 1097        %else
 1098           Printstring(" =");  Printstring(Regid(-A));  Spaces(2)
 1099        %finish
 1100     %else
 1101        Printstring(" used*");  Write(A, -1)
 1102     %finish
 1103     Printstring("  u:");     Print Hex(Used(R), 5)
 1104     Printstring("  k:");     Write(Ktimes(R), 0)
 1105     Newline
 1106  %end
 1107  
 1108  %routine Monitor N(%integer N, %string(255) Text)
 1109     Select Output(Report)
 1110     Printstring(Text)
 1111     Write(N, 8)
 1112     Newline
 1113     Select Output(Directives Out)
 1114  %end
 1115  
 1116  %routine Monitor Register(%integer R, %string(127) Text)
 1117     Select Output(Report)
 1118     Printstring(Text);  Spaces(9-length(Text));  Space
 1119     Show Reg(R)
 1120     Select Output(Directives Out)
 1121  %end
 1122  
 1123  %routine Monitor(%record(Stackfm)%name V, %string(127) Text)
 1124     Select Output(Report)
 1125     Printstring(Text);  Spaces(9-length(Text));  Space
 1126     Display(V, 6)
 1127     Select Output(Directives Out)
 1128  %end
 1129  
 1130  %routine Mon Regid(%integer R, %string(127) Text)
 1131     Select Output(Report)
 1132     Printstring(Regid(R));  Space
 1133     Printstring(Text)
 1134     Newline
 1135     Select Output(Directives Out)
 1136  %end
 1137  
 1138  %routine Display Knowledge
 1139     %record(Knowfm)%name K
 1140     Select Output(Report)
 1141     K == Knowing
 1142     %while K ## Nil %cycle
 1143        Printstring(Regid(K_Reg));  Printstring(" = ")
 1144        Printstring(Typeid(K_Ftype>>4));  Space
 1145        Printstring(Formid(K_Ftype&15));  Space
 1146        BD(K_Base, K_Disp)
 1147        %if K_Extra # 0 %start
 1148           Printstring(" X:");  Write(K_Extra, 1)
 1149        %finish
 1150        %if K_Area # 0 %start
 1151           Printstring(" A:");  Write(K_Area, 1)
 1152        %finish
 1153        %if K_Oper # 0 %start
 1154           Space;  Printstring(OperId(K_Oper))
 1155           Write(K_Opnd, 1)
 1156        %finish
 1157        Newline
 1158        K == K_Link
 1159     %repeat
 1160     Select Output(Directives Out)
 1161  %end
 1162  
 1163  %routine Show Where
 1164     Select Output(Report)
 1165     Printstring(" at line ");  Write(Current Line, 0)
 1166     Printstring(" in file ".Include File) %if Include File # ""
 1167     newline
 1168  %end
 1169  
 1170  %routine Fail(%string(63) Why)
 1171  
 1172     %routine Pcode(%integer S)
 1173        %if S >= 128 %start
 1174           Printstring("128+")
 1175           S = S-128
 1176        %finish
 1177        %if ' ' <= S <= 126 %start
 1178           Printsymbol('''');  Printsymbol(S);  Printsymbol('''')
 1179        %finish
 1180        write(S, 3)
 1181     %end
 1182  
 1183     %routine Err(%integer Stream)
 1184        %integer R
 1185        %record(Stackfm)%name U, S
 1186        Select Output(Stream)
 1187        Newline
 1188        Printstring("====> Pass 2 fails -- ");  Printstring(Why)
 1189        Show Where
 1190        Printstring("Code ");      Pcode(Code)
 1191        Printstring(" Pending ");  Pcode(Pending)
 1192        Newline
 1193        %for R = R0, 1, R15 %cycle
 1194           Show Reg(R) %unless Activity(R) <= 0
 1195        %repeat
 1196        S == Stack
 1197        %while S ## Nil %cycle
 1198           Printstring("S:");  Display(S, 5)
 1199           S == S_Stack
 1200        %repeat
 1201        U == Using
 1202        %while U ## Nil %cycle
 1203           Printstring("U:");  Display(U, 5)
 1204           U == U_Using
 1205        %repeat
 1206        Newline
 1207        %monitor
 1208     %end
 1209     Err(Report)                            {terminal}
 1210     Err(Listing)                            {listing}
 1211     %stop
 1212  %end
 1213  
 1214  %routine Warn(%integer Fault, %string(63) What)
 1215     Select Output(Report)
 1216     Interface_Faults = Interface_Faults+Fault
 1217     %if Fault = 0 %then Printstring("Warning: ") %c
 1218+                  %else Printstring("*Error: ")
 1219     Printstring(What)
 1220     Show Where
 1221     Select Output(Directives Out)
 1222  %end
 1223  
 1224  %routine Not in Yet
 1225     Fail("***Not implemented yet***")
 1226  %end
 1227  
 1228  %routine Dir1(%integer Code)
 1229     Flush Code
 1230     Printsymbol(Code)
 1231     Pending Auto = 0
 1232  %end
 1233  
 1234  %routine Dir2(%integer Code, Arg1)
 1235     Flush Code
 1236     Printsymbol(Code)
 1237     Dump Encoded(Arg1)
 1238     Pending Auto = 0 %unless Code = Dir Line
 1239  %end
 1240  
 1241  %routine Dir3(%integer Code, Arg1, Arg2)
 1242     Flush Code
 1243     Printsymbol(Code)
 1244     Dump Encoded(Arg1)
 1245     Dump Encoded(Arg2)
 1246     Pending Auto = 0
 1247  %end
 1248  
 1249  %routine Dir4(%integer Code, Arg1, Arg2, Arg3)
 1250     Flush Code
 1251     Printsymbol(Code)
 1252     Dump Encoded(Arg1)
 1253     Dump Encoded(Arg2)
 1254     Dump Encoded(Arg3)
 1255     Pending Auto = 0
 1256  %end
 1257  
 1258  %record(Workfm)%map Work Area(%integer N)
 1259     %record(WorkVfm)%name W
 1260     %integer E, S, X
 1261     %on * %start
 1262        E = Event_Event;  S = Event_Sub;  X = 0; ! Event_Extra not supported in bootstrapping compiler
 1263        Fail("too many work areas:".itos(E, 0))
 1264     %finish
 1265     Monitor N(N, "work area") %if Diag&MonOperand # 0
 1266     W == Work List
 1267     %while N > 30 %cycle
 1268        N = N-30
 1269        %if W_Link == NIL %start
 1270           W_Link == NEW(WorkVfmType)
 1271           W_Link = 0
 1272        %finish
 1273        W == W_Link
 1274     %repeat
 1275     %result == W_W(N)
 1276  %end
 1277  
 1278  %record(Labelfm)%map Ilabel(%integer N)
 1279     %integer X, J
 1280     %record(Ilabelfm)%name I
 1281     %record(Labelfm)%name L
 1282     Fail("internal label/1") %if N > Max Label
 1283     X = N>>8
 1284  !0.9!   I == Ilabels(X)
 1285  {0.9}   I == Ilabels(X)_Label
 1286     %if I == NIL %start
 1287        I == New(Ilabelfm Type)
 1288  !0.9! Ilabels(X) == I
 1289  {0.9} Ilabels(X)_Label == I
 1290        I_Link == Ilabel List;  Ilabel List == I
 1291        %for J = 0, 1, 255 %cycle
 1292           L == I_Lab(J)
 1293           L_Lab = Defined
 1294           L_Env == NIL
 1295        %repeat
 1296     %finish
 1297     %result == I_Lab(N&255)
 1298  %end
 1299  
 1300  %routine Select Area(%integer Area Id, %integername Base)
 1301     Dir3(Dir Area, Area Id>>8, Base)
 1302     Current Area = Area Id
 1303     Ca == Base
 1304  %end
 1305  
 1306  %routine Select Code Area
 1307     Select Area(Code Area, Code Base)
 1308  %end
 1309  
 1310  %routine Select Constant Area
 1311     Select Area(Constant Area, Constant Base)
 1312  %end
 1313  
 1314  %routine Select Own Area
 1315     Select Area(Own Area, Own Base)
 1316  %end
 1317  
 1318  %routine Select Own Array Area
 1319     Select Area(Own Array Area, Own Array Base)
 1320  %end
 1321  
 1322  %include "plant.inc"
 &1     %routine Dump Byte(%integer B)
 &2        Printsymbol(Dir Dump);  Printsymbol(1)
 &3        Printsymbol(B&255)
 &4        Ca = Ca+1
 &5     %end
 &6     
 &7     %routine Dump Half(%integer H)
 &8        Printsymbol(Dir Dump);  Printsymbol(2)
 &9        Printsymbol(H&255)
 &10       Printsymbol(H>>8&255)
 &11       Ca = Ca+2
 &12    %end
 &13    
 &14    %routine Dump Word(%integer N)
 &15       Printsymbol(Dir Dump);  Printsymbol(4)
 &16       Printsymbol(N&255)
 &17       Printsymbol(N>>8&255)
 &18       Printsymbol(N>>16&255)
 &19       Printsymbol(N>>24)
 &20       Decode(Ca, N) %if Diag & Mon Code # 0 %and Current Area = Code Area
 &21       Ca = Ca+4
 &22    %end
 &23    
 &24    %integerfn Actual Register(%integer Base)
 &25       %record(Stackfm)%name T
 &26       %if Base >= 128 %start               {base reigster not actual register}
 &27          %if Base = Local %start
 &28             Base = Fp
 &29          %else %if Base > 128              {???}
 &30             T == Display Info(Base)
 &31             Loadup(T)
 &32             Base = T_Base
 &33             Release and Drop(T)            {it will be used immediately ***?***}
 &34          %finish
 &35       %finish
 &36       %result = Actual(Base)
 &37    %end
 &38    
 &39    %integerfn Just(%integer R)
 &40       %result = Actual Register(R)
 &41    %end
 &42    
 &43    %integerfn Nothing
 &44       %result = 16_0200 0000
 &45    %end
 &46    
 &47    %integerfn Immediate(%integer N)
 &48       %integer Rot = 16
 &49       %if N # 0 %start
 &50          Rot = Rot-1 %and N = N>>2 %while N&3 = 0
 &51          %result = -1 %if N>>8 # 0
 &52       %finish
 &53       %result = (Rot&15)<<8 ! N ! 16_0200 0000
 &54    %end
 &55    
 &56    %integerfn Ishift(%integer Rm, By, How)
 &57       Fail("Bad immediate shift") %if How&2_1 000 0000 # 0
 &58       %result = Actual Register(Rm) ! (By&2_11111)<<(3+4) ! How
 &59    %end
 &60    
 &61    %integerfn Rshift(%integer Rm, Rs, How)
 &62       Fail("Bad register shift") %if How&2_1 000 0000 = 0
 &63       %result = Actual Register(Rm) ! Actual Register(Rs)<<(4+4) ! How&2_0 111 0000
 &64    %end
 &65    
 &66    %integerfn Rot(%integer N, By)
 &67       %result = (N&255 ! By<<8) ! 16_0200 0000
 &68    %end
 &69    
 &70    %owninteger Pending Pop = 0
 &71    
 &72    %routine Plant1(%integer Fn, Rn, Rd, X)
 &73       Dump Word((Fn!!Invert Cond) ! Actual Register(Rn)<<16 %c
 &74  +                                ! Actual Register(Rd)<<12 ! X)
 &75       Forget(Rd) %unless (Fn>>23)&3 = 2_10
 &76    %end
 &77    
 &78    %routine Plant2(%integer Fn, Rd, %record(Stackfm)%name V)
 &79       %integer N, Shift, Sign, D, P, Base, Vbase, Extra = 0
 &80       %record(Stackfm)%name W
 &81       Fn = Fn ! Byte Op %if V_Type = Bytes
 &82       Simplify(V)
 &83       D = V_Disp
 &84       %if V_Form = AutoI %start
 &85          D = Type Size(V_Type)
 &86          Fn = Fn ! Post Indexed
 &87       %else %if V_Form = AutoD
 &88          D = -Type Size(V_Type)
 &89          Fn = Fn ! Write Back
 &90       %else %if V_Form # Direct
 &91          Fail("illegal load/store")
 &92       %finish
 &93    
 &94       %if V_Index == NIL %start
 &95          Fail("Bad displacement") %unless -16_0FFF <= D <= 16_0FFF
 &96          %if D >= 0 %then Fn = Fn ! 16_0080 0000 %c
 &97  +                  %else D = -D
 &98          Fn = Fn ! D
 &99          %if D = 0 %start
 &100            Pending Auto N  = 0
 &101            Pending Auto    = V_Base
 &102            Pending Auto Ca = Ca
 &103         %finish
 &104      %else         {V_Index ## NIL}
 &105         Fail("Bad index displacement") %unless D = 0
 &106         N = V_Xsize;  Fail("Zero Xsize") %if N = 0
 &107         P = Power(N)
 &108         %if P >= 0 %start
 &109            Loadup(V_Index)
 &110         %else
 &111            P = 0
 &112            Sign = N&16_80000000
 &113            P = P+1 %and N = (N>>1)!Sign %while N&1 = 0
 &114            Operate(MULx, V_Index, Literal(N));  V_Xsize = 1
 &115            Loadup(V_Index)
 &116         %finish
 &117         Fn = Fn ! 16_0080 0000 ! Reg Index ! Ishift(V_Index_Base, P, Logical Left)
 &118      %finish
 &119      %if V_Base = 0 %start             {absolute!!}
 &120         %if V_Record == NIL %start
 &121            %if V_Area < 0 %start
 &122               Loadup(V)
 &123               Fn = Fn ! Actual Register(V_Base)<<16
 &124            %else
 &125               Fail("No absolute yet")
 &126            %finish
 &127         %else
 &128            Loadup(V_Record)
 &129            V_Base = V_Record_Base
 &130            Drop(V_Record);  V_Record == NIL
 &131            Fn = Fn ! Actual Register(V_Base)<<16
 &132         %finish
 &133      %else
 &134         Fn = Fn ! Actual Register(V_Base)<<16
 &135      %finish
 &136      Forget(V_Base) %if FN&(Post Indexed ! Write Back) # 0
 &137      Fn = Fn !! Post Indexed ! Actual Register(Rd)<<12
 &138      Dump Word(Fn!!Invert Cond)
 &139      Release(Extra) %if Extra # 0
 &140      %if Fn&16_0010 0000 # 0 %start   {load}
 &141         Forget(Rd) 
 &142      %else                            {store}
 &143         Forget Destination(V)
 &144         Remember(Rd, V)
 &145      %finish
 &146   %end
?W unused
?VBASE unused
?BASE unused
?SHIFT unused
 &147   
 &148   %routine Plant3(%integer Fn, N)
 &149      Dump Word((Fn!!Invert Cond) ! N&16_00FF FFFF)
 &150   %end
 &151   
 &152   %routine Plant4(%integer Fn, Rn, Operand)
 &153      Dump Word((Fn!!Invert Cond) ! Actual Register(Rn)<<16 ! Operand&16_FFFF)
 &154      Forget(Rn) %if Fn&Write Back # 0
 &155   %end
 &156   
 &157   %routine Plant5(%integer Fn, Offset)
 &158      Dump Word((Fn!!Invert Cond) ! Offset&16_00FF FFFF)
 &159   %end
 &160   
 &161   %routine Plant6(%integer Op, Fd, %record(Stackfm)%name V)
 &162      {*** WARNING: the displacement is a WORD offset, not a byte one ***}
 &163      %integer N, Shift, Sign, D, P, Base, Vbase
 &164      %record(Stackfm)%name W
 &165      Simplify(V)
 &166      D = V_Disp
 &167      Fail("Floating-point alignment") %if D&3 # 0
 &168      D = D//4   {convert to word displacement}
 &169      %if V_Form = AutoI %start
 &170         D = Type Size(V_Type)>>2
 &171         Op = Op ! Post Indexed
 &172      %else %if V_Form = AutoD
 &173         D = -(Type Size(V_Type)>>2)
 &174         Op = Op ! Write Back
 &175      %else %if V_Form # Direct
 &176         Fail("illegal load/store")
 &177      %finish
 &178      %if V_Index ## NIL %start
 &179         Fail("Fp Disp?") %unless -255 <= D <= 255
 &180         W == Copy(V)      {Note - this reverts to a byte displacement}
 &181         Loadup Address(W)
 &182         W_Type = V_Type;  W_Form = Direct
 &183         Plant6(Op, Fd, W)
 &184         Release and Drop(W)
 &185         %return
 &186      %finish
 &187      %if D >= 0 %then Op = Op ! 16_0080 0000 %c
 &188 +               %else D = -D
 &189      Op = Op ! D
 &190   !!!   %if D = 0 %start
 &191   !!!      Pending Auto N  = 2
 &192   !!!      Pending Auto    = V_Base
 &193   !!!      Pending Auto Ca = Ca
 &194   !!!   %finish
 &195      %if V_Base = 0 %start             {absolute!!}
 &196         %if V_Record == NIL %start
 &197            %if V_Area < 0 %start
 &198               Fail("Bad external") %if V_Type # Integers
 &199               Loadup(V)
 &200               Op = Op ! Actual Register(V_Base)<<16
 &201            %else
 &202               Fail("No absolute yet")
 &203            %finish
 &204         %else
 &205            Loadup(V_Record)
 &206            V_Base = V_Record_Base
 &207            Drop(V_Record);  V_Record == NIL
 &208            Op = Op ! Actual Register(V_Base)<<16
 &209         %finish
 &210      %else
 &211         Op = Op ! Actual Register(V_Base)<<16
 &212      %finish
 &213      Forget(V_Base) %if Op&(Post Indexed ! Write Back) # 0
 &214      Op = Op !! Post Indexed ! Actual Register(Fd)<<12
 &215      Dump Word(Op!!Invert Cond)
 &216      %if Op&16_0010 0000 # 0 %start   {load}
 &217         Forget(Fd) 
 &218      %else                            {store}
 &219         Forget Destination(V)
 &220         Remember(Fd, V)
 &221      %finish
 &222   %end
?VBASE unused
?BASE unused
?P unused
?SIGN unused
?SHIFT unused
?N unused
 &223   
 &224   %routine Plant7(%integer Op, Fn, Rd, Fm)
 &225      Fm = Actual(Fm) %if Op&Small Constant = 0
 &226      Dump Word((Op!!Invert Cond) ! Actual(Fn)<<16 ! Actual(Rd)<<12 ! Fm)
 &227      %if Op&16_0010 0000 = 0 %then Forget(Fn) %else Forget(Rd)
 &228   %end
 &229   
 &230   %routine Plant8(%integer Op, Fn, Fm)         {CPST}
 &231      Fm = Actual(Fm) %if Op&Small Constant = 0
 &232      Dump Word((Op!!Invert Cond) ! Actual(Fn)<<16 ! Fm)
 &233   %end
 &234   
 &235   %routine Plant9(%integer Op, Fn, Fd, Fm)     {CPDO}
 &236      Fm = Actual(Fm) %if Op&Small Constant = 0
 &237      Dump Word((Op!!Invert Cond) ! Actual(Fn)<<16 ! Actual(Fd)<<12 ! Fm)
 &238      Forget(Fd)
 &239   %end
 &240   %endoffile
 1323  %include "load.inc"
 &1     %recordformat Constfm(%integer N, Store, Type, V1, R1, V2, R2)
 &2     %constinteger Const Zero    = 1,     {constant is zero}
 &3   +               Const Mone    = 2,     {constant is minus one}
 &4   +               Const Rot     = 3,     {get with one rotate}
 &5   +               Const Not Rot = 4,     {get with two rotates}
 &6   +               Const None    = 5      {must go via store}
 &7     
 &8     %routine Test Assigned
 &9        Dir1(Dir Assigned);  Ca = Ca+4;  Refs = Refs+1
 &10    %end
 &11    
 &12    %routine Float(%record(Stackfm)%name V, %integer R)
 &13       %integer N
 &14       %longreal Long
 &15       R = FPR %if R = AnyF
 &16       %if Iconst(V) %start
 &17          %if 0 <= V_Disp <= 5 %or V_Disp = 10 %start
 &18             N = V_Disp;  N = 7 %if V_Disp = 10
 &19             Plant9(MVF ! Small Constant, 0, R, N)
 &20          %else %if -5 <= V_Disp <= 0 %or V_Disp = -10
 &21             N = -V_Disp;  N = 7 %if N = 10
 &22             Plant9(MNF ! Small Constant, 0, R, N)
 &23          %else
 &24             Long = V_Disp;  V_Rval = Long
 &25             Convert Format(V, Lreals)
 &26             Store Real Constant(V)
 &27             Dir4(Dir Real Load, Actual(R), V_Disp, 1);  Forget(R)
 &28             Refs = Refs+1;  Ca = Ca+4
 &29          %finish
 &30       %else
 &31          Loadup(V)
 &32          Plant7(FLT, R, V_Base, 0);  Release(V_Base)
 &33       %finish
 &34       V_Type = Lreals;  V_Form = Address
 &35       V_Base = R;       V_Disp = 0
 &36       V_Area = 0
 &37       Claim(R)
 &38    %end
 &39    
 &40    %routine Load Safely(%record(Stackfm)%name V, %integer R)
 &41       %if R = Any %start
 &42          Load Protected(V)
 &43       %else %if R = AnyF
 &44          Float(V, AnyF) %unless Floating(V)
 &45          Load Protected(V)
 &46       %else
 &47          Hazard(R) %unless Activity(R) = 1 %and V_Base = R
 &48          Load(V, R)
 &49       %finish
 &50    %end
 &51    
 &52    %routine Characterise Constant(%integer N, %record(Constfm)%name C)
 &53       %integer Sh, V, S, X
 &54       %constbytearray Bits(0:15) = 0, 1, 1, 2, 1, 2, 2, 3,
 &55  +                                 1, 2, 2, 3, 2, 3, 3, 4
 &56       C_N = N
 &57       V = N
 &58       %if V = 0 %start
 &59          C_Type = Const Zero;  %return
 &60       %else %if V = -1
 &61          C_Type = Const Mone;  %return
 &62       %else
 &63          X = V;  S = 0          {count 1 bits}
 &64          %cycle
 &65             S = S+Bits(X&15);  X = X>>4
 &66          %repeat %until X = 0
 &67    
 &68          C_Type = Const Rot
 &69          C_Type = Const Not Rot %and V = ~V %if S > 16
 &70    
 &71          %if V # 0 %start
 &72             Sh = 16
 &73             Sh = Sh-1 %and V = V>>2 %while V&3 = 0
 &74             C_R1 = Sh&15;  C_V1 = V&255;  V = V>>8
 &75             C_R2 = 0;   C_V2 = 0
 &76             %if V # 0 %start
 &77                Sh = Sh-4
 &78                Sh = Sh-1 %and V = V>>2 %while V&3 = 0
 &79                C_R2 = Sh&15;  C_V2 = V&255;  V = V>>8
 &80             %finish
 &81          %finish
 &82          C_Type = Const None %if V # 0
 &83       %finish
 &84    %end
 &85    
 &86    %routine Now in Register(%record(Stackfm)%name V, %integer R, Inherit)
 &87       Remember(R, V) %if Inherit # 0
 &88       %if V_Index ## Nil %start
 &89          Release and Drop(V_Index);  V_Index == Nil
 &90       %finish
 &91       %if V_Record ## Nil %start
 &92          Release and Drop(V_Record);  V_Record == Nil
 &93       %finish
 &94       Release(V_Base)
 &95       V_Data = 0;  V_Base = R;  V_Form = Address;  V_Type = Rtype(R)
 &96       Claim(R)
 &97    %end
 &98    
 &99    %routine Simple Load(%record(Stackfm)%name V, %integer R)
 &100      %record(Stackfm)%name W, B1, B2
 &101      %record(Constfm)      C
 &102      %integer P, N, X, T, Check
 &103   
 &104      Optimise(V, 1)
 &105      %if InReg(V) %start
 &106         %return %if V_Base = R %or (R = Any %and V_Base <= Any) %c
 &107 +                              %or (R = AnyF %and V_Base >= F0)
 &108      %finish
 &109   
 &110      %if R = Any %then R = Gpr %else %if R = AnyF %then R = Fpr
 &111      Hazard(R) %unless V_Base = R %and Activity(R) = 1
 &112   
 &113      Simplify(V)
 &114   
 &115      Float(V, R) %and %return %if R >= F0 %and %not Floating(V)
 &116   
 &117      %if Iconst(V) %start
 &118         Characterise Constant(V_Disp, C)
 &119         %if C_Type = Const Zero  %start
 &120            Plant1(MOV, 0, R, Rot(0, 0))
 &121         %else %if C_Type = Const Mone
 &122            Plant1(MVN, 0, R, Rot(0, 0))
 &123         %else %if C_Type = Const Rot
 &124            Plant1(MOV, 0, R, Rot(C_V1, C_R1))
 &125            Plant1(ORR, R, R, Rot(C_V2, C_R2)) %if C_V2 # 0
 &126         %else %if C_Type = Const Not Rot
 &127            Plant1(MVN, 0, R, Rot(C_V1, C_R1))
 &128            Plant1(EOR, R, R, Rot(C_V2, C_R2)) %if C_V2 # 0
 &129         %else{%if C_Type = Const None}
 &130            Constant Base = (Constant Base+3)&(\3)
 &131            W == Literal(Constant Base);  W_Form = Direct;  W_Area = Constant Area
 &132            Select Constant Area
 &133            Dump Word(C_N)
 &134            Select Code Area
 &135            Dir3(Dir Const Load, Actual(R), Constant Base-4);  Forget(R)
 &136            Refs = Refs+1;  Ca = Ca+4
 &137            Release and Drop(W)
 &138         %finish
 &139         Now in Register(V, R, 1)
 &140      %else %if V_Form = Address
 &141         %if InReg(V) %start
 &142            %if V_Type >= Reals %start
 &143               Plant9(MVF, 0, R, V_Base)
 &144            %else
 &145               Plant1(MOV, 0, R, Just(V_Base))
 &146            %finish
 &147            Now in Register(V, R, 1)
 &148            %return
 &149         %finish
 &150         %if V_Type >= Reals %start
 &151            Store Real Constant(V)
 &152            Dir4(Dir Real Load, Actual(R), V_Disp, 1);  Forget(R)
 &153            Refs = Refs+1;  Ca = Ca+4
 &154            Remember(R, V)
 &155            Now in Register(V, R, 1)
 &156            %return
 &157         %finish
 &158         %if V_Area = Constant Area %start
 &159            Dir3(Dir Const Addr, Actual(R), V_Disp);  Forget(R)
 &160            Refs = Refs+1;  Ca = Ca+4
 &161            Now in Register(V, R, 1)
 &162            %return
 &163         %finish
 &164         %if V_Index ## NIL %start
 &165            %if V_Record ## NIL %and V_Base = 0 %start
 &166               Loadup(V_Record)
 &167               V_Base = V_Record_Base
 &168               Drop(V_Record);  V_Record == NIL
 &169            %finish
 &170            %if V_Base = 0 %start
 &171               Not in Yet
 &172            %else
 &173               P = Power(V_Xsize)
 &174               %if P >= 0 %start         {can use logical shift}
 &175                  Loadup(V_Index)
 &176                  Plant1(ADD, V_Base, R, Ishift(V_Index_Base, P, Logical Left))
 &177               %else                     {must use multiply}
 &178                  Operate(MULx, V_Index, Literal(V_Xsize))
 &179                  Loadup(V_Index);  V_Xsize = 1
 &180                  Plant1(ADD, V_Base, R, Just(V_Index_Base))
 &181               %finish
 &182            %finish
 &183            {at this point R contains BASE + scaled*INDEX}
 &184            %if V_Disp > 0 %start
 &185               Characterise Constant(V_Disp, C)
 &186               %if C_Type = Const Rot %start
 &187                  Plant1(ADD, R, R, Rot(C_V1, C_R1))
 &188                  Plant1(ADD, R, R, Rot(C_V2, C_R2)) %if C_V2 # 0
 &189               %else %if C_Type = Const None
 &190      Nasty:      Constant Base = (Constant Base+3)&(\3)
 &191                  Select Constant Area
 &192                  Dump Word(V_Disp)
 &193                  Select Code Area
 &194                  X = GPR
 &195                  Dir3(Dir Const Load, Actual(X), Constant Base-4);  Forget(X)
 &196                  Refs = Refs+1;  Ca = Ca+4
 &197                  Plant1(ADD, V_Base, R, Just(X))
 &198               %else
 &199                  Fail("Bad displacement")
 &200               %finish
 &201            %else %if V_Disp < 0
 &202               Characterise Constant(-V_Disp, C)
 &203               %if C_Type = Const Rot %start
 &204                  Plant1(SUB, R, R, Rot(C_V1, C_R1))
 &205                  Plant1(SUB, R, R, Rot(C_V2, C_R2)) %if C_V2 # 0
 &206               %else %if C_Type = Const None
 &207                  W == Literal(V_Disp);  W_Form = Direct;  W_Base = Pc
 &208                  Loadup(W)
 &209                  Plant1(SUB, R, R, Just(W_Base))
 &210                  Release and Drop(W)
 &211               %else
 &212                  ->Nasty
 &213               %finish
 &214            %finish
 &215         %else            {V_Index==NIL}
 &216            N = V_Disp;  P = ADD
 &217            N = -N %and  P = SUB %if N < 0
 &218            Characterise Constant(N, C)
 &219            %if C_Type = Const Zero  %start
 &220               Plant1(MOV, 0, R, Just(V_Base))
 &221            %else %if C_Type = Const Rot
 &222               Plant1(P, V_Base, R, Rot(C_V1, C_R1))
 &223               Plant1(P,      R, R, Rot(C_V2, C_R2)) %if C_V2 # 0
 &224            %else %if C_Type = Const None
 &225               W == Literal(C_N);  Loadup(W)
 &226               Plant1(P, V_Base, R, Just(W_Base))
 &227               Release and Drop(W)
 &228            %else
 &229               Fail("negate error")
 &230            %finish
 &231         %finish
 &232         Now in Register(V, R, 1)
 &233      %else %if V_Form = Direct
 &234         Check = V_Flags & Checkable
 &235         Check = 0 %if Unassigned = 0 %or V_Flags & Known Ass # 0
 &236         %if V_Area # 0 %start
 &237            %if V_Area = Constant Area %start
 &238               %if V_Type = Integers %start
 &239                  Dir3(Dir Const Load, Actual(R), V_Disp)
 &240               %else %if V_Type = Lreals
 &241                  Dir4(Dir Real Load, Actual(R), V_Disp, 1)
 &242               %else %if V_Type = Reals
 &243                  Dir4(Dir Real Load, Actual(R), V_Disp, 0)
 &244               %else %if V_Type = Bytes %or V_Type = Shorts
 &245                  T = V_Type
 &246                  Amap(V);  Load(V, R)
 &247                  V_Type = T;  V_Form = Direct;  Load(V, R)
 &248                  %return
 &249               %else
 &250                  Fail("Bad constant type")
 &251               %finish
 &252               Refs = Refs+1;  Ca = Ca+4
 &253               Forget(R)
 &254               Now in Register(V, R, 1)
 &255               %return
 &256            %finish
 &257            %if V_Area < 0 %start
 &258               Fail("Bad external spec type") %if V_Type # Integers
 &259               Dir3(Dir Spec Load, Actual(R), -V_Area);  Forget(R)
 &260               Refs = Refs+1;  Ca = Ca+4
 &261               Now in Register(V, R, 1)
 &262               %return
 &263            %finish
 &264         %finish
 &265   
 &266         %if V_Type = Bytes %start
 &267            Plant2(LDR, R, V)
 &268            Now in Register(V, R, 1)
 &269            %if Check # 0 %start
 &270               Plant1(CMP ! Scc, R, 0, Immediate(16_80))
 &271               Test Assigned
 &272            %finish
 &273         %else %if V_Type = Shorts
 &274            Simplify(V)
 &275            %if V_Index ## NIL %or V_Record ## NIL %start
 &276               Loadup Address(V);  V_Type = Shorts;  V_Form = Direct
 &277            %finish
 &278            {Be careful to load [base+1] before [base+0] to leave}
 &279            {the possibility of auto increment}
 &280            B1 == Copy(V);  Advance(B1, Bytes, 0)    {low byte}
 &281            B2 == Copy(V);  Advance(B2, Bytes, 1)    {high byte}
 &282            B1_Flags = B1_Flags ! Known Ass
 &283            B2_Flags = B2_Flags ! Known Ass
 &284            Load(B2, R14);  Load(B1, R);  Loadup(B2) {in case of hazard}
 &285            %if Check # 0 %start
 &286               Plant1(CMP ! Scc,           B1_Base, 0, Immediate(16_80))
 &287               Plant1(CMP ! Scc ! Cond EQ, B2_Base, 0, Immediate(16_80))
 &288               Test Assigned
 &289            %finish
 &290            Plant1(MOV, 0, B2_Base, Ishift(B2_Base, 24, Logical Left))
 &291            Plant1(ORR, B1_Base, R, Ishift(B2_Base, 16, Arithmetic Right))
 &292            Release and Drop Pair(B1, B2)
 &293            Now in Register(V, R, 1)
 &294         %else %if V_Type = Reals
 &295            Plant6(LDFS, R, V)
 &296            Now in Register(V, R, 1)
 &297            %if Check # 0 %start
 &298               B1 == Literal(0)
 &299               B1_Type = Lreals;  B1_Form = Direct;  B1_Base = SB
 &300               Loadup(B1);  Release and Drop(B1)
 &301               Plant8(CMF, B1_Base, R)
 &302               Test Assigned
 &303            %finish
 &304         %else %if V_Type = Lreals
 &305            Plant6(LDFD, R, V)
 &306            Now in Register(V, R, 1)
 &307            %if Check # 0 %start
 &308               B1 == Literal(0)
 &309               B1_Type = Lreals;  B1_Form = Direct;  B1_Base = SB
 &310               Loadup(B1);  Release and Drop(B1)
 &311               Plant8(CMF, B1_Base, R)
 &312               Test Assigned
 &313            %finish
 &314         %else
 &315            Plant2(LDR, R, V)                 {default to integer}
 &316            Now in Register(V, R, 1)
 &317            %if Check # 0 %start
 &318               B1 == Literal(0)
 &319               B1_Form = Direct;  B1_Base = SB
 &320               Loadup(B1);  Release and Drop(B1)
 &321               Plant1(CMP ! Scc, B1_Base, 0, Just(R))
 &322               Test Assigned
 &323            %finish
 &324         %finish
 &325      %else %if V_Form = AutoD
 &326         Plant2(LDR, R, V);  Forget(V_Base)
 &327         Now in Register(V, R, 1)
 &328      %else %if V_Form = AutoI
 &329         Plant2(LDR, R, V);  Forget(V_Base)
 &330         Now in Register(V, R, 1)
 &331      %else
 &332         Fail("Unknown type for LOAD")
 &333      %finish
 &334   %end
 &335   
 &336   %routine Multiply(%record(Stackfm)%name V, W, %integer R)
 &337      {BEWARE: this uses TEST ZERO and can there for alter INVERT, but}
 &338      {        multiply can occur during a condition evaluation therefore}
 &339      {        INVERT needs to be preserved across this call}
 &340   
 &341      %routine Cmul(%integer From, To, By)
 &342         %integer X, Op, With, T
 &343         %if       By&1 = 0 %start
 &344            Op = MOV;  With = 0
 &345         %else %if By&3 = 1
 &346            Op = ADD;  With = From
 &347         %else    {By&3 = 3}
 &348            By = By+1
 &349            Op = RSB;  With = From
 &350         %finish
 &351         X = 0;  X = X+1 %and By = By>>1 %until By&1 # 0
 &352         %if By = 1 %start
 &353            T = From
 &354         %else
 &355            T = Gpr
 &356            Cmul(From, T, By)
 &357         %finish
 &358         Plant1(Op, With, To, Ishift(T, X, Logical Left))
 &359      %end
 &360   
 &361      %integer L, Inv
 &362      %record(Stackfm)%name Z
 &363      %if Iconst(W) %start
 &364         Load Safely(V, R)
 &365         Fail("Zero multiply") %if W_Disp = 0
 &366         Cmul(V_Base, V_Base, W_Disp)
 &367      %else
 &368         Optimise(V, 1)
 &369         Optimise(W, 1)
 &370         Z == Literal(0)
 &371         %if R = Any %or R = AnyF %or Activity(R) # 0 %start {SCR/87/448}
 &372            Load Protected(Z)
 &373         %else
 &374            Load(Z, R)
 &375         %finish
 &376         Load Protected(V)
 &377         Load Protected(W)
 &378         Inv = Invert;  Invert = 0
 &379         L = New label
 &380         Define Label(L)
 &381         Plant1(MOV!Scc,            0, W_Base, Ishift(W_Base, 1, Logical Right))
 &382         Plant1(ADD ! Cond CS, Z_Base, Z_Base, Just(V_Base))
 &383         Plant1(MOV,                0, V_Base, Ishift(V_Base, 1, Logical Left))
 &384         Jump To(L, NE)
 &385         Release(V_Base);  V_Base = Z_Base;  Drop(Z)
 &386         Load(V, R)
 &387         Invert = Inv
 &388      %finish
 &389      Release and Drop(W)
 &390   %end
 &391   
 &392   %routine Divide(%record(Stackfm)%name V, W, %integer R, Q, U)
 &393      {Q = 0 for quotient, 1 for remainder}
 &394      {U = 0 for unsigned}
 &395      %integer P, L, Op
 &396      %if (Q = 0 %or U = 0) %and Iconst(W) %start
 &397         P = Power(W_Disp)
 &398         %if P > 0 %start
 &399            %if U = 0 %start        {unsigned}
 &400               %if Q = 0 %start     {divide}
 &401                  W_Disp = P
 &402                  Op = RSHx
 &403               %else                {REM}
 &404                  W_Disp = \((-1)<<P)
 &405                  Op = ANDx
 &406               %finish
 &407               Operate(Op, V, W)
 &408               Load(V, R)
 &409               %return
 &410            %finish
 &411            %if P <= 8 %start
 &412               Load Safely(V, R)
 &413               Plant1(CMP!Scc, V_Base, 0, Nothing)
 &414               L = New Label
 &415               Jump To(L, GE)
 &416               Plant1(ADD, V_Base, V_Base, Rot(W_Disp-1, 0))
 &417               Define label(L)
 &418               Plant1(MOV, 0, V_Base, Ishift(V_Base, P, Arithmetic Right))
 &419               Drop(W)
 &420               %return
 &421            %finish
 &422         %finish
 &423      %finish
 &424      %if U = 0 %then Op = Prim Udiv %else Op = Prim Div
 &425      Load Safely(V, R1)
 &426      Load Pair(V, R1, W, R2)
 &427      Prim(Op)
 &428      %if Q = 0 %start      {quotient wanted}
 &429         Release(R1);  Claim(R0);  V_Base = R0
 &430      %finish
 &431      Load(V, R)
 &432      Release and Drop(W)
 &433   %end
 &434   
 &435   %routine Complex Load(%record(Stackfm)%name V, %integer R)
 &436      %switch C,C2(NOTx:REXPx)
 &437      %constintegerarray Real Op(RNEGx:REXPx) = MNF, ABS, ADF, SUF, MUF, DVF, POW
 &438      %record(Stackfm)%name W, B
 &439      %record(Constfm)      Cx
 &440      %integer Oper, Op, Reg2, N, Pa
 &441   
 &442      W == V_Link;  V_Link == NIL
 &443      Oper = V_Oper;  V_Oper = 0
 &444   
 &445      %if Oper >= RNEGx %or R >= F0 %start
 &446         Fail("real load?") %if R <= Any
 &447         %if Oper = REXPx %start
 &448            Load Safely(V, F0)
 &449            Load Pair(V, F0, W, R0)
 &450            Prim(Real Exp)
 &451            Release and Drop(W)       {done here in case of HAZARD corrupting it}
 &452            Load(V, R)
 &453            %return
 &454         %finish
 &455         %if Oper < RNEGx %start
 &456            V_Link == W;  V_Oper = Oper;  Load(V, Any)  {integer operation}
 &457            Load(V, R)
 &458            %return
 &459         %finish
 &460         Load Safely(V, R)
 &461         Op = Real Op(Oper)
 &462         %if W == NIL %start     {neg, abs}
 &463            Plant9(Op, 0, V_Base, V_Base)
 &464         %else
 &465            %if Iconst(W) %and (0 <= W_Disp <= 5 %or W_Disp = 10) %start
 &466               Reg2 = W_Disp;  Reg2 = 7 %if Reg2 = 10
 &467               Op = Op ! Small Constant
 &468            %else
 &469               Load(W, AnyF)
 &470               Reg2 = W_Base
 &471            %finish
 &472            Plant9(Op, V_Base, V_Base, Reg2)
 &473         %finish
 &474         ->OK
 &475      %finish
 &476   
 &477      %if Oper = EXPx %start
 &478         Load Safely(V, R1)
 &479         Load Pair(V, R1, W, R2)
 &480         Prim(IntExp)
 &481         Release and Drop(W)       {done here in case of HAZARD}
 &482         Load(V, R)
 &483         %return
 &484      %finish
 &485   
 &486      %if Oper = MODx %start
 &487         Load Safely(V, R1)
 &488         Load Pair(V, R1, W, R2)
 &489         Prim(MODULUS)
 &490         Release and Drop(W)
 &491         %return
 &492      %finish
 &493   
 &494      Multiply(V, W, R)       %and %return %if Oper = MULx
 &495      Divide  (V, W, R, 0, 1) %and %return %if Oper = DIVx
 &496      Divide  (V, W, R, 1, 1) %and %return %if Oper = REMx
 &497      Divide  (V, W, R, 0, 0) %and %return %if Oper = UDIVx
 &498      Divide  (V, W, R, 1, 0) %and %return %if Oper = UREMx
 &499   
 &500      %if Oper = SUBx %and Iconst(V) %start
 &501         Characterise Constant(V_Disp, Cx)
 &502         %if Cx_Type = Const Rot %start
 &503            Load(W, R);  R = W_Base
 &504            Plant1(RSB, W_Base, R, Rot(Cx_V1, Cx_R1))
 &505            Plant1(ADD, R,      R, Rot(Cx_V2, Cx_R2)) %if Cx_V2 # 0;  ->OK Set
 &506         %else %if Cx_Type = Const Mone
 &507            Load Safely(W, R);  R = W_Base
 &508            Plant1(MVN, 0,      R, Just(W_Base))
 &509    OK Set: V_Base = R;  V_Disp = 0;  W_Base = 0;  ->OK
 &510         %finish
 &511      %finish
 &512   
 &513      %if Pending Auto # 0 %and  Oper = ADDx %and Iconst(W) %c
 &514 +                         %and -4095 <= W_Disp <= 4095 %start
 &515         Pa = Pending Auto               {the optimise will destroy it}
 &516         Optimise(V, 1)
 &517         %if Inreg(V) %and V_Base = Pa %c
 &518 +                    %and (Pending Auto N = 0 %or |W_Disp>>2| <= 255) %start
 &519            Dir3(Dir Modify, Ca-Pending Auto Ca, W_Disp>>Pending Auto N)
 &520            Forget(Pa)
 &521            Drop(W)
 &522            Load Safely(V, R)
 &523            %return
 &524         %finish
 &525      %finish
 &526   
 &527      %if V_Type = Shorts %and (Oper = ANDx %or Oper = BICx) %and Iconst(W) %start
 &528         N = W_Disp
 &529         N = \N %if Oper = BICx
 &530         %if N>>16 = 0 %start
 &531            Release and Drop(W)
 &532            %if N <= 255 %start
 &533               Advance(V, Bytes, 0)                     {low byte}
 &534               Operate(ANDx, V, Literal(N)) %if N # 255
 &535               Load(V, R)
 &536            %else %if N&255 = 0
 &537               V_Oper = 0;  V_Link = 0
 &538               Advance(V, Bytes, 1)  {high byte}
 &539               Operate(ANDx, V, Literal(N>>8)) %if N>>8 # 255
 &540               Operate(LSHx, V, Literal(8))
 &541               Load(V, R)
 &542            %else
 &543               B == Copy(V);  Advance(B, Bytes, 1)  {high byte}
 &544               Operate(ANDx, B, Literal(N>>8)) %if N>>8 # 255
 &545               Advance(V, Bytes, 0)                     {low byte}
 &546               Operate(ANDx, V, Literal(N&255)) %if N&255 # 255
 &547               {be careful to load [b+1] before [b+0] to leave}
 &548               {the possibility of auto increment}
 &549               Loadup(B);  Load Safely(V, R)
 &550               Loadup(B);  Load Safely(V, R)        {in case of hazard}
 &551               Plant1(ORR, V_Base, V_Base, Ishift(B_Base, 8, Logical Left))
 &552               Release and Drop(B)
 &553            %finish
 &554            %return
 &555         %finish
 &556      %finish
 &557   
 &558      Load Safely(V, R);  R = V_Base
 &559      %if W ## NIL %start
 &560         %if Iconst(W) %start
 &561            %if Oper = EXTx %start
 &562               Plant1(MOV, 0, R, Ishift(V_Base, W_Disp&16_FFFF, Logical Right))
 &563               N = (-1)<<(W_Disp>>16)
 &564               Plant1(AND, R, R, Immediate(\N))
 &565               ->OK
 &566            %finish
 &567            %if Oper = ANDx %and Immediate(W_Disp) < 0 %start
 &568               Oper = BICx;  W_Disp = \W_Disp
 &569            %finish
 &570            Characterise Constant(W_Disp, Cx)
 &571            %if Cx_Type = Const Mone %start
 &572               Plant1(SUB, V_Base, R, Rot(1, 0))    %and ->OK %if Oper = ADDx
 &573               Plant1(ADD, V_Base, R, Rot(1, 0))    %and ->OK %if Oper = SUBx
 &574               Plant1(MVN, 0,      R, Just(V_Base)) %and ->OK %if Oper = XORx
 &575            %else %if Cx_Type = Const Rot
 &576               ->C2(Oper)
 &577   
 &578   C2(ADDx):   Op = ADD;  ->C2OK
 &579   C2(SUBx):   Op = SUB;  ->C2OK
 &580   C2(BICx):   Op = BIC;  ->C2OK
 &581   C2( ORx):   Op = ORR;  ->C2OK
 &582   C2(XORx):   Op = EOR;  ->C2OK
 &583   C2(ANDx):   Op = AND %and ->C2OK %if Cx_V2 = 0
 &584               ->Hard
 &585   
 &586   C2OK:       Plant1(Op, V_Base, R, Rot(Cx_V1, Cx_R1))
 &587               Plant1(Op, R,      R, Rot(Cx_V2, Cx_R2)) %if Cx_V2 # 0
 &588               ->OK
 &589   
 &590   C2(LSHx):   Warn(1, "Dubious shift") %if W_Disp>>5 # 0
 &591               Plant1(MOV, 0,      R, Ishift(V_Base, W_Disp&31, Logical Left));   ->OK
 &592   C2(RSHx):   Warn(1, "Dubious shift") %if W_Disp>>5 # 0
 &593               Plant1(MOV, 0,      R, Ishift(V_Base, W_Disp&31, Logical Right));  ->OK
 &594            %else %if Cx_Type = Const Not Rot
 &595               Characterise Constant(-W_Disp, Cx)
 &596               ->Hard %unless Cx_Type = Const Rot
 &597               Op = SUB %and ->C2OK %if Oper = ADDx
 &598               Op = ADD %and ->C2OK %if Oper = SUBx
 &599               Warn(1, "Dubious shift") %if Oper = RSHx %or Oper = LSHx
 &600            %finish
 &601         %finish
 &602      %finish
 &603   
 &604   Hard:
 &605   C2(*):
 &606   
 &607      Loadup(W) %unless W == NIL
 &608      ->C(Oper)
 &609   
 &610   C(NOTx): Plant1(MVN,         0, R, Just(V_Base));  ->OUT
 &611   C(NEGx): Plant1(RSB,   V_Base,  R, Nothing);       ->OUT
 &612   C(ABSx): Plant1(ADD!Scc,     R, R, Nothing)   {set CC}    {SCR/87/422}
 &613            %begin
 &614               %integer Label
 &615               Label = New Label
 &616               Jump To(Label, GE)
 &617               Plant1(RSB, R, R, Nothing)
 &618               Define Label(Label)
 &619            %end
 &620            ->OUT
 &621   
 &622   C(ADDx): Plant1(ADD, V_Base, R, Just(W_Base));  ->OK
 &623   C(SUBx): Plant1(SUB, V_Base, R, Just(W_Base));  ->OK
 &624   C(BICx): Plant1(BIC, V_Base, R, Just(W_Base));  ->OK
 &625   C(ANDx): Plant1(AND, V_Base, R, Just(W_Base));  ->OK
 &626   C( ORx): Plant1(ORR, V_Base, R, Just(W_Base));  ->OK
 &627   C(XORx): Plant1(EOR, V_Base, R, Just(W_Base));  ->OK
 &628   C(LSHx): Plant1(MOV, 0,      R, Rshift(V_Base, W_Base, Logical Left  R));  ->OK
 &629   C(RSHx): Plant1(MOV, 0,      R, Rshift(V_Base, W_Base, Logical Right R));  ->OK
 &630   
 &631   C(*):    Not in Yet
 &632   
 &633   OK:      Release and Drop(W) %if W ## NIL
 &634   OUT:
 &635   %end
 &636   
 &637   %routine Load(%record(Stackfm)%name V, %integer R)
 &638   !  Monitor(V, "->Load ".RegId(R)) %if Diag&MonMove # 0
 &639      %if V_Oper = 0 %then Simple  Load(V, R) %c
 &640 +                   %else Complex Load(V, R)
 &641      Monitor(V, "<-Load") %if Diag&MonMove # 0
 &642   %end
 &643   
 &644   %routine Load Pair(%record(Stackfm)%name A, %integer Ar,
 &645 +                    %record(Stackfm)%name B, %integer Br)
 &646      %if B_Oper # 0 %or B_Record ## NIL %or B_Index ## NIL %start
 &647         Load(B, Br)
 &648         Load(A, Ar)
 &649         Load(B, Br)
 &650      %else
 &651         Load(A, Ar)
 &652         Load(B, Br)
 &653         Load(A, Ar)
 &654      %finish
 &655   %end
 &656   
 &657   %routine Load Trio(%record(Stackfm)%name A, %integer Ar,
 &658 +                    %record(Stackfm)%name B, %integer Br,
 &659 +                    %record(Stackfm)%name C, %integer Cr)
 &660      %if B_Oper # 0 %or B_Record ## NIL %or B_Index ## NIL %start
 &661         Load(B, Br)
 &662         Load Pair(A, Ar, C, Cr)
 &663      %else %if C_Oper # 0 %or C_Record ## NIL %or C_Index ## NIL
 &664         Load(C, Br)
 &665         Load Pair(A, Ar, B, Br)
 &666      %else
 &667         Load(A, Ar)
 &668         Load Pair(B, Br, C, Cr)
 &669      %finish
 &670      Load(A, Ar);  Load(B, Br);  Load(C, Cr)
 &671   %end
 &672   %endoffile
 1324  %include "repeat.inc"
 &1     %routine Repeat(%routine Body, %record(Stackfm)%name Times, %integer Inc, How)
 &2        %integer Label
 &3        %return %if Iconst(Times) %and Times_Disp <= 0
 &4        Loadup(Times)
 &5        Label = New Label;  Define Label(Label)
 &6           Body
 &7           Plant1(SUB!Scc, Times_Base, Times_Base, Immediate(Inc))
 &8        Jump To(Label, How)
 &9        Remember Zero(Times_Base) %if How = NE
 &10       Release and Drop(Times)
 &11    %end
 &12    %endoffile
 1325  
 1326  %integerfn Cheapest(%integer Low, High)
 1327     %integer R, A, U
 1328     %integer Min Activity,
 1329+             Min Known,
 1330+             Min Reg,       {default to R3 or F3}
 1331+             Oldest
 1332  
 1333     Min Activity = 1000
 1334     Min Known    = 1000
 1335     Min Reg      = 0
 1336     Used Time    = Used Time+1
 1337     Oldest       = Used Time
 1338     %for R = Low, 1, High %cycle
 1339        A = Activity(R);  %continue %if A < 0                    {locked}
 1340        U = Used(R)
 1341        %if A = Min Activity %start
 1342           %if Min Known > Ktimes(R) %start
 1343              Min Reg   = R
 1344              Min Known = Ktimes(R)
 1345              Oldest    = U
 1346           %else %if Min Known = Ktimes(R)
 1347              %if Oldest > U %start             {choose the oldest}
 1348                 Min Reg = R
 1349                 Oldest  = U
 1350              %finish
 1351           %finish
 1352        %else %if A < Min Activity
 1353           Min Activity = A
 1354           Min Reg      = R
 1355           Min Known    = Ktimes(R)
 1356           Oldest       = U
 1357        %finish
 1358     %repeat
 1359     Fail("all registers lost") %if Min Reg = 0
 1360     Used(Min Reg) = Used Time
 1361     Hazard(Min Reg) %unless Min Activity = 0
 1362     %result = Min Reg
 1363  %end
 1364  
 1365  %integerfn GPR
 1366     %result = Cheapest(R0, R8)
 1367  %end
 1368  
 1369  %integerfn FPR
 1370     %result = Cheapest(F0, F7)
 1371  %end
 1372  
 1373  %record(Stackfm)%map Register(%integer Reg)
 1374     %record(Stackfm)%name R
 1375     R == Descriptor
 1376     %if Reg = Any %start
 1377        R_Type = Integers
 1378        Reg    = Cheapest(R0, R8)
 1379     %else %if Reg = AnyF
 1380        R_Type = Lreals
 1381        Reg    = Cheapest(F0, F7)
 1382     %else
 1383        R_Type = Integers
 1384        R_Type = Lreals %if Reg >= F0
 1385     %finish
 1386     R_Base = Reg;  Claim(Reg)
 1387     %result == R
 1388  %end
 1389  
 1390  %predicate Locked(%integer R)
 1391     %true %if R >= 128 %or R = 0 %or Activity(R) < 0
 1392     %false
 1393  %end
 1394  
 1395  %predicate Properly Aligned(%record(Stackfm)%name V, %integer Mask)
 1396     %true %if V_Type = Sets
 1397     %if V_Type = Records %start
 1398        %false %if V_Format >= 0
 1399        %true  %if Var(-V_Format)_Disp = 3    {format needs word alignment}
 1400     %finish
 1401     %false %unless Locked(V_Base)
 1402     %true %if V_Form = Direct %c
 1403+         %and V_Record == Nil %c
 1404+         %and V_Index  == Nil %c
 1405+         %and V_Disp&Mask = 0
 1406     %false
 1407  %end
 1408  
 1409  %include "simplify.inc"
 &1     %routine Simplify(%record(Stackfm)%name V)
 &2        %integer N, D
 &3        %record(Stackfm)%name R, X
 &4     
 &5        Monitor(V, "->Simplify") %if Diag&MonOperate # 0
 &6     
 &7        %if V_Oper # 0 %start              {Can do nothing but load it?}
 &8           Loadup(V);  ->OK
 &9        %finish
 &10    
 &11       %if V_Record ## Nil %start
 &12          %if V_Form = Address %and V_Disp = 0 %c
 &13  +                            %and V_Base = 0 %c
 &14  +                            %and V_Index == Nil %start
 &15             {it all reduces to just the value of _record}
 &16             R == V_Record
 &17             V_Data = R_Data
 &18             R_Index == Nil;  R_Record == Nil;  Drop(R)
 &19             Simplify(V)
 &20             ->OK
 &21          %finish
 &22          Simplify(V_Record)
 &23          Loadup(V_Record) %if V_Record_Index ## Nil   %c
 &24  +                        %or V_Record_Form # Address %c
 &25  +                        %or V_Record_Area # 0
 &26          V_Disp = V_Disp+V_Record_Disp;  V_Record_Disp = 0
 &27          {V_Record is now either the constant 0 or a register}
 &28          %if V_Record_Base = None %start            {it's zero}
 &29             Drop(V_Record);  V_Record == Nil
 &30          %else %if V_Base = None                    {replace the base}
 &31             V_Base = V_Record_Base
 &32             Drop(V_Record);  V_Record == Nil
 &33          %else %if V_Index == Nil                   {make it the index}
 &34             V_Index == V_Record;  V_Xsize = 1
 &35             V_Record == Nil
 &36          %else                                      {combine it with the index}
 &37             Operate(ADDx, V_Index, V_Record)
 &38             V_Record == Nil
 &39          %finish
 &40       %finish
 &41    
 &42       %if V_Index ## Nil %start
 &43          Simplify(V_Index) 
 &44          %if V_Area = Constant Area %start     {temp frig}
 &45             X == Literal(V_Disp);  V_Disp = 0
 &46             X_Area = Constant Area;  V_Area = 0
 &47             Loadup(X)
 &48             %if V_Base = None %start
 &49                V_Base = X_Base
 &50                Drop(X)
 &51             %else
 &52                Operate(MULx, V_Index, Literal(V_Xsize));  V_Xsize = 1
 &53                Operate(ADDx, V_Index, X)
 &54             %finish
 &55          %else
 &56             N = Power(V_Xsize)
 &57             %if N < 0 %start
 &58                Operate(MULx, V_Index, Literal(V_Xsize));  V_Xsize = 1
 &59                Loadup(V_Index)
 &60             %finish
 &61          %finish
 &62          {There is no disp field on indexed instructions}
 &63          %if V_Disp # 0 %start
 &64             %if V_Xsize # 1 %start
 &65                Operate(MULx, V_Index, Literal(V_Xsize));  V_Xsize = 1
 &66             %finish
 &67             Operate(ADDx, V_Index, Literal(V_Disp));  V_Disp = 0
 &68             Loadup(V_Index)
 &69          %finish
 &70       %finish
 &71    
 &72       %routine Ensure Displacement(%integer D, Type)
 &73          %record(Stackfm)%name W
 &74          %if Type = Integers %start
 &75             %return %if -16_0FFF <= D <= 16_0FFF
 &76          %else
 &77             Fail("real address error") %if D&3 # 0
 &78             %return %if -255 <= D//4 <= 255
 &79          %finish
 &80          V_Disp = 0
 &81          W == Literal(D);  Loadup(W)
 &82          %if V_Index == NIL %start
 &83             V_Index == W;  V_Xsize = 1
 &84          %else
 &85             %if V_Xsize # 1 %start
 &86                Operate(MULx, V_Index, Literal(V_Xsize));  V_Xsize = 1
 &87             %finish
 &88             Operate(ADDx, V_Index, W)
 &89          %finish
 &90          Simplify(V)
 &91       %end
 &92    
 &93       D = V_Disp
 &94       %if Iconst(V) %start                          {adjust the type of constants}
 &95                %if  16_0000 <= D <= 16_00FF %then V_Type = Bytes %c
 &96  +       %else %if -16_8000 <= D <= 16_7FFF %then V_Type = Shorts
 &97       %else %if V_Form # Address
 &98          %if V_Type = Lreals %or V_Type = Reals %start
 &99             Ensure Displacement(D, Reals)
 &100         %else %if V_Type <= Addrs
 &101            Ensure Displacement(D, Integers)
 &102         %finish
 &103      %finish
 &104   OK:Monitor(V, "<-Simplify") %if Diag&MonOperate # 0
 &105   %end
 &106   %endoffile
 1410  
 1411  %routine Apply Index(%record(Stackfm)%name V, X, %integer Xsize)
 1412     %integer N, MulOp
 1413     %if Iconst(X) %and V_Form = Direct %start  {fold it in}
 1414        N = V_Disp+X_Disp*Xsize
 1415        V_Disp = N
 1416        Drop(X)
 1417        %return
 1418     %finish
 1419     %if V_Index == Nil %start                  {no index, just add the new one}
 1420        V_Index == X;  V_Xsize = Xsize
 1421     %else %if V_Xsize = Xsize                  {equal scaling}
 1422        Operate(ADDx, V_Index, X)               {add in the new bit}
 1423     %else                                      {different scaling}
 1424        MulOp = MULx
 1425        Operate(MulOp, V_Index, Literal(V_Xsize)) %unless V_Xsize = 1
 1426        Operate(MulOp, X,       Literal(Xsize))   %unless   Xsize = 1
 1427        Operate(ADDx, V_Index, X)
 1428        V_Xsize = 1
 1429     %finish
 1430  %end
 1431  
 1432  %routine Fix Unitary String(%record(Stackfm)%name V)
 1433     %integer Len, Val, At
 1434     %owninteger Null Address = -1
 1435  
 1436     %integerfn Locate(%integer Len, Char)
 1437        %integer Here
 1438        Constant Base = (Constant Base+3)&(\3)
 1439        Here = Constant Base
 1440        Select Constant Area
 1441        Dump Byte(Len);  Dump Byte(Char) %if Len # 0
 1442        Select Code Area
 1443        %result = Here
 1444     %end
 1445  
 1446     %if V_Type = Strings %and V_Bias = 1 %start             {""}
 1447        Null Address = Locate(0, 0) %if Null Address < 0
 1448        At = Null Address
 1449        Len = 1
 1450     %else %if V_Type = Sets
 1451        Build Set(V);  %return
 1452     %else %if V_Type <= Addrs
 1453        Val = V_Disp&255
 1454        Warn(1, "string character out of range") %if Val # V_Disp
 1455        At = Locate(1, Val)
 1456        Len = 2
 1457     %else
 1458        Fail("bad tostring type")
 1459     %finish
 1460     V_Disp = At;  V_Type = Strings;  V_Form = Direct
 1461     V_Area = Constant Area;  V_Format = Len;  V_Bias = Len
 1462  %end
 1463  
 1464  %routine Amap(%record(Stackfm)%name V)
 1465     %record(Stackfm)%name W
 1466     %if V_Form = Address %start
 1467        Fix Unitary String(V)
 1468     %else %if V_Oper # 0
 1469        Fail("Amap:oper")
 1470     %finish
 1471     V_Type = Integers          {all addresses are integers}
 1472     %return %if V_Form = AutoD {special for the stack}
 1473  
 1474     %if V_Form = Proc %start
 1475        %if V_Flags&Xproc Spec # 0 %start      {case 1 - an external}
 1476           Hazard(R13);  Forget(R13)
 1477           Dir2(Dir xThunk, V_Disp)            {         load @vector into R13}
 1478           Refs = Refs+1;  Ca = Ca+4
 1479           V_Type = Integers;  V_Form = Address
 1480           V_Base = R13;       V_Disp = 0;  V_Area = 0
 1481           Claim(R13)
 1482        %else %if V_Flags&Parameter # 0        {case 2 - already a parameter}
 1483           V_Type = Integers;  V_Form = Direct;  V_Area = 0
 1484        %else %if V_Flags&XprocDef # 0         {case 3 - simplified}
 1485           Hazard(R13);  Forget(R13)
 1486           Dir2(Dir Thunk, V_Disp)             {         load @vector into R13}
 1487           Refs = Refs+1;  Ca = Ca+4
 1488           V_Type = Integers;  V_Form = Address
 1489           V_Base = R13;       V_Disp = 0;  V_Area = 0
 1490           Claim(R13)
 1491        %else                                  {cases 3 & 4}
 1492           Fail("cannot address local procedures")
 1493        %finish
 1494     %else
 1495        Fail("Amap:form") %unless V_Form = Direct
 1496        V_Form = Address
 1497        %if V_Index ## Nil %and Iconst(V_Index) %start
 1498           V_Disp = V_Disp+V_Index_Disp*V_Xsize
 1499           Drop(V_Index);  V_Index == Nil
 1500        %finish
 1501        %if V_Disp = 0 %and V_Index == Nil %and V_Record ## Nil %start
 1502           {convert addr 0(X) into X}
 1503           W == V_Record
 1504           V_Data = W_Data
 1505           W_Index == Nil;  W_Record == Nil;  Drop(W)
 1506        %finish
 1507     %finish
 1508     Monitor(V, "Amap<-") %if Diag&MonOperate # 0
 1509  %end
 1510  
 1511  %routine Make AutoI(%record(Stackfm)%name V, %integer Type)
 1512     Amap(V)            {get its address}
 1513     Load Protected(V)  {to a safe register}
 1514     V_Type = Type;  V_Form = AutoI
 1515  %end
 1516  
 1517  %routine Vmap(%record(Stackfm)%name V, %integer New Type)
 1518     %record(Stackfm)%name W, C
 1519     %integer D = 0
 1520     Fail("Vmap:type") %unless Integers <= V_Type <= Addrs
 1521     %if V_Oper = ADDx %start
 1522        C == V_Link
 1523        %if Iconst(C) %start
 1524           D = C_Disp
 1525           Drop(C);  V_Link == NIL;  V_Oper = 0
 1526        %finish
 1527     %finish
 1528     Loadup(V) %if V_Oper # 0   {PSR}
 1529     %if V_Form # Address %start
 1530        W == Descriptor;  W_Data = V_Data
 1531        V_Data = 0
 1532        V_Record == W
 1533        V_Disp = D
 1534     %finish
 1535     V_Type   = Internal Type(New Type);  V_Form = Direct
 1536     V_Format = Type Fmt(New Type)
 1537     Monitor(V, "Vmap<-") %if Diag&MonOperate # 0
 1538  %end
 1539  
 1540  %routine Fmap(%integer NewType)
 1541     Hazard(Stack_Base) %if InReg(Stack)
 1542     Fail("Bad type for Fmap") %unless Stack_Type = Integers %c
 1543+                              %and    Stack_Form # Address
 1544     Stack_Form = Proc
 1545     Stack_Type = NewType
 1546     Stack_Flags = Stack_Flags ! Answer ! Parameter
 1547  %end
 1548  
 1549  %routine Advance(%record(Stackfm)%name V, %integer Type, By)
 1550     %integer Check Flag
 1551     %if V_Form # AutoD %start
 1552        Check Flag = V_Flags&Checkable
 1553        Amap(V)
 1554        Operate(ADDx, V, Literal(By))
 1555        Vmap(V, Type)
 1556        V_Flags = V_Flags ! Check Flag
 1557     %else
 1558        V_Type = Type
 1559     %finish
 1560  %end
 1561  
 1562  !!%include "mtables.inc" {moved outside of mcode.inc because of "context" error}
 1563  !!%include "mcode.inc"
 1564  
 1565  { I need to move the above include in-line to avoid a "* 2755 dictionary full" error}
 1566  
 1567  !##########################################################################
 1568  %routine Machine Code
 1569     !%include "mtables.inc" { moved outside of Machine Code because of "context" error}
 1570  !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 1571  %constinteger Max Opcode = 95
 1572  
 1573  %conststring(4)%array Opcode(1:Max Opcode) =
 1574+   "ABS",  "ACS",  "ADC",  "ADD",  "ADF",
 1575+   "AND",  "ASN",  "ATN",    "B",  "BAL",
 1576+   "BCC",  "BCS",  "BEQ",  "BGE",  "BGT",
 1577+   "BHI",  "BIC",   "BL", "BLAL", "BLCC",
 1578+  "BLCS",  "BLE", "BLEQ", "BLGE", "BLGT",
 1579+  "BLHI", "BLLE", "BLLS", "BLLT", "BLMI",
 1580+  "BLNE", "BLNV", "BLPL",  "BLS",  "BLT",
 1581+  "BLVC", "BLVS",  "BMI",  "BNE",  "BNV",
 1582+   "BPL",   "BR",  "BVC",  "BVS",  "CMF",
 1583+  "CMFE",  "CMN",  "CMP",  "CNF", "CNFE",
 1584+   "COS",  "DVF",  "EOR",  "EXP",  "FDV",
 1585+   "FIX",  "FLT",  "FML",  "FRD",  "LDF",
 1586+   "LDM",  "LDR",  "LGN",  "LOG",  "MNF",
 1587+   "MOV",  "MUF",  "MVF",  "MVN",  "ORR",
 1588+   "POL",  "POW",  "RDF",  "RFC",  "RFS",
 1589+   "RMF",  "RND",  "RPW",  "RSB",  "RSC",
 1590+   "RSF",  "SBC",  "SIN",  "SQT",  "STF",
 1591+   "STM",  "STR",  "SUB",  "SUF",  "SWI",
 1592+   "TAN",  "TEQ",  "TST",  "WFC",  "WFS"
 1593  
 1594  %constbytearray Type(1:Max Opcode) =
 1595+      10,     10,      1,      1,     10,
 1596+       1,     10,     10,      5,      5,
 1597+       5,      5,      5,      5,      5,
 1598+       5,      1,      5,      5,      5,
 1599+       5,      5,      5,      5,      5,
 1600+       5,      5,      5,      5,      5,
 1601+       5,      5,      5,      5,      5,
 1602+       5,      5,      5,      5,      5,
 1603+       5,      5,      5,      5,      9,
 1604+       9,      1,      1,      9,      9,
 1605+      10,     10,      1,     10,     10,
 1606+       7,      7,     10,     10,      6,
 1607+       4,      2,     10,     10,     10,
 1608+       1,     10,     10,      1,      1,
 1609+      10,     10,     10,      7,      7,
 1610+      10,     10,     10,      1,      1,
 1611+      10,      1,     10,     10,      6,
 1612+       4,      2,      1,     10,      3,
 1613+      10,      1,      1,      7,      7
 1614  
 1615  %constintegerarray Value(1:Max Opcode) =
 1616+ 16_0E208100,16_0EC08100,16_00A00000,16_00800000,16_0E000100,16_00000000,
 1617+ 16_0EB08100,16_0ED08100,16_EA000000,16_EA000000,16_3A000000,16_2A000000,
 1618+ 16_0A000000,16_AA000000,16_CA000000,16_8A000000,16_01C00000,16_EB000000,
 1619+ 16_EB000000,16_3B000000,16_2B000000,16_DA000000,16_0B000000,16_AB000000,
 1620+ 16_CB000000,16_8B000000,16_DB000000,16_9B000000,16_BB000000,16_4B000000,
 1621+ 16_1B000000,16_FB000000,16_5B000000,16_9A000000,16_BA000000,16_7B000000,
 1622+ 16_6B000000,16_4A000000,16_1A000000,16_FA000000,16_5A000000,16_EA000000,
 1623+ 16_7A000000,16_6A000000,16_0E90F110,16_0ED0F110,16_01600000,16_01400000,
 1624+ 16_0EB0F110,16_0EF0F110,16_0E908100,16_0E400100,16_00200000,16_0E708100,
 1625+ 16_0EA00100,16_0E100110,16_0E000110,16_0E900100,16_0EB00100,16_0C100100,
 1626+ 16_08100000,16_04100000,16_0E608100,16_0E508100,16_0E108100,16_01A00000,
 1627+ 16_0E100100,16_0E008100,16_01E00000,16_01800000,16_0EC00100,16_0E600100,
 1628+ 16_0E500100,16_0E500110,16_0E300110,16_0E800100,16_0E308100,16_0E700100,
 1629+ 16_00600000,16_00E00000,16_0E300100,16_00C00000,16_0E808100,16_0E408100,
 1630+ 16_0C000100,16_08000000,16_04000000,16_00400000,16_0E200100,16_0F000000,
 1631+ 16_0EA08100,16_01200000,16_01000000,16_0E400110,16_0E200110
 1632  
 1633  !%endoffile
 1634  !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 1635  
 1636  %integer Op Num, Op Type, Op Value=0, Op Length
 1637     %integer Operands, N, J, Key, P, X = 0, SymP, Disp
 1638     %integer Rn, Rd, Rs, Rm, Sh, Rot, Ud, Reg1, Reg2
 1639     %integer Fdst, Fs1, Fs2
 1640     %string(7)  Op String
 1641     %record(Varfm)%name W
 1642     %switch Ot(-1:10)
 1643  
 1644     %routine Mc Error(%string(127) Text)
 1645        %routine Err(%integer Stream)
 1646           Select Output(Stream)
 1647           Printstring("*");  Write(Current Line, 4)
 1648           Printstring(" ".Op String.": ".Text)
 1649           Newline
 1650        %end
 1651        Err(Listing)                                {listing}
 1652        Err(Report)                                 {terminal}
 1653        Fail("Bang") %if Diag&Mon Bang # 0
 1654        Interface_Faults = Interface_Faults+1
 1655        Select Output(Directives Out)
 1656        %signal 14
 1657     %end
 1658  
 1659     %routine Find Opcode
 1660        %integer Min, Max, P
 1661        %string(4) Key
 1662        Key = "0"                         { this was a bare 0 - was that some new automatic type casting??? }
 1663                                          { it gets immediately overwritten so WTF???                       }
 1664        Op Length = Length(Op String)
 1665        %if Op Length <= 3 %start
 1666           SymP = Op Length
 1667           Key = Op String
 1668        %else
 1669           SymP = 3
 1670  	                                { many 'tostring' calls added as that definitely was automatic type casting }
 1671           Key = tostring(Charno(Op String, 1)).tostring(Charno(Op String, 2)).tostring(Charno(Op String, 3))
 1672           %if Charno(Op String, 1) = 'B' %and Charno(Op String, 2) = 'L' %c
 1673+                                         %and Op Length >= 4 %start
 1674              Key = Key.tostring(Charno(Op String, 4))
 1675              SymP = 4
 1676           %finish
 1677        %finish
 1678        Min = 1;  Max = Max Opcode
 1679        %while Min <= Max %cycle
 1680           P =(Min+Max)>>1
 1681           %if Opcode(P) = Key %start
 1682              Op Num = P;  Op Type = Type(Op Num);  Op Value = Value(Op Num)
 1683              %return
 1684           %finish
 1685           %if Key > Opcode(P) %then Min = P+1 %else Max = P-1
 1686        %repeat
 1687        %if Op String = "BYTE" %or Op String = "BYTE1" %start
 1688           Op Num = -1;  Op Type = -1;  SymP = OpLength
 1689        %else %if Op String = "BYTE2"
 1690           Op Num = -2;  Op Type = -1;  SymP = OpLength
 1691        %else %if Op String = "BYTE4"
 1692           Op Num = -3;  Op Type = -1;  SymP = OpLength
 1693        %finish %else Mc Error("unknown opcode")
 1694     %end
 1695  
 1696     %predicate Match(%integer Wanted)
 1697        %false %unless Pending = Wanted
 1698        Readsymbol(Pending)
 1699        %true
 1700     %end
 1701  
 1702     %predicate PMatch(%integer Wanted)
 1703        %false %unless Pending = Wanted ! 128
 1704        Readsymbol(Pending)
 1705        %true
 1706     %end
 1707  
 1708     %predicate Literal(%integername N)
 1709        %if Match('N') %start
 1710           N = Four Bytes
 1711           %true
 1712        %finish
 1713        %if Match(128+'b') %start
 1714           N = Pending;  Readsymbol(Pending)
 1715           %true
 1716        %finish
 1717        %false %unless Match('-')
 1718        Mc Error("constant expected") %unless Literal(N)
 1719        N = -N
 1720        %true
 1721     %end
 1722  
 1723     %routine Want(%integer Sym)
 1724        Mc Error(Tostring(Sym)." expected") %unless Match(Sym)
 1725     %end
 1726  
 1727     %routine Want Literal(%integername N)
 1728        Mc Error("constant expected") %unless Literal(N)
 1729     %end
 1730  
 1731     %routine Register(%integername R)
 1732        Mc Error("Register expected") %unless Literal(R) %and 0 <= R <= 15
 1733     %end
 1734  
 1735     %routine F Register(%integername R)
 1736        Mc Error("Floating register expected") %unless Literal(R) %c
 1737+                                                 %and 16+0 <= R <= 16+7
 1738     %end
 1739  
 1740     %routine Set CC
 1741        %constintegerarray CC(0:15) =
 1742+                'E'<<8 ! 'Q', 'N'<<8 ! 'E', 'C'<<8 ! 'S', 'C'<<8 ! 'C',
 1743+                'M'<<8 ! 'I', 'P'<<8 ! 'L', 'V'<<8 ! 'S', 'V'<<8 ! 'C',
 1744+                'H'<<8 ! 'I', 'L'<<8 ! 'S', 'G'<<8 ! 'E', 'L'<<8 ! 'T',
 1745+                'G'<<8 ! 'T', 'L'<<8 ! 'E', 'A'<<8 ! 'L', 'N'<<8 ! 'V'
 1746        %integer Sym, C
 1747        %if SymP+1 < Op Length %start
 1748           Sym = Charno(Op String, SymP+1)<<8 ! Charno(Op String, SymP+2)
 1749           %for C = 0, 1, 15 %cycle
 1750              %if CC(C) = Sym %start
 1751                 Op Value = Op Value ! C<<28
 1752                 SymP = SymP+2
 1753                 %return
 1754              %finish
 1755           %repeat
 1756        %finish
 1757        Op Value = Op Value ! 16_E000 0000   {default to always}
 1758     %end
 1759  
 1760     %routine Comma
 1761        Mc Error("comma missing") %unless Match(',')
 1762     %end
 1763  
 1764     %predicate Omatch(%integer Sym)
 1765        %false %unless SymP < Op Length %and Charno(Op String, SymP+1) = Sym
 1766        SymP = SymP+1
 1767        %true
 1768     %end
 1769  
 1770     %on 14 %start
 1771        Readsymbol(Pending) %while Pending # ';'
 1772     %else
 1773        Op String = ""
 1774        %while Pending # '_' %cycle
 1775           Op String = Op String.Tostring(Pending) %if Length(Op String) # 7
 1776           Readsymbol(Pending)
 1777        %repeat
 1778        Readsymbol(Pending)
 1779        Find Opcode
 1780        Set CC %if Op Type > 0 {funnies} %and Op Type # 5 {branch}
 1781        ->Ot(Op Type)
 1782  
 1783     {data processing}
 1784  
 1785        %constbytearray Litsh(1:4) = 2_100 0000, 2_000 0000,
 1786+                                    2_010 0000, 2_110 0000
 1787  
 1788        %constbytearray Regsh(1:4) = 2_101 0000, 2_001 0000,
 1789+                                    2_011 0000, 2_111 0000
 1790  
 1791        %routine Bad Shift
 1792           Mc Error("unknown type of shift")
 1793        %end
 1794  
 1795        %routine Get Shift
 1796           %integer Sh
 1797           %if PMatch('A') %start
 1798              %if PMatch('S') %and PMatch('R') %start
 1799                 Sh = 1
 1800              %else
 1801                 Bad Shift
 1802              %finish
 1803           %else %if PMatch('L')
 1804              %if PMatch('S') %start
 1805                 %if PMatch('L') %start
 1806                    Sh = 2
 1807                 %else %if PMatch('R')
 1808                    Sh = 3
 1809                 %else
 1810                    Bad Shift
 1811                 %finish
 1812              %else
 1813                 Bad Shift
 1814              %finish
 1815           %else %if PMatch('R')
 1816              %if PMatch('R') %start
 1817                 Bad Shift %unless PMatch('X')
 1818                 Sh = 0
 1819              %else %if PMatch('O') %and PMatch('R')
 1820                 Sh = 4
 1821              %else
 1822                 Bad Shift
 1823              %finish
 1824           %else
 1825              Bad Shift
 1826           %finish
 1827           %if Sh = 0 %start
 1828              Op Value = Op Value ! 2_00000 110 <<4   {RRX}
 1829           %else %if Match('#')
 1830              Want Literal(N) 
 1831              Mc Error("shift out of range") %unless 0 <= N <= 32
 1832              Op Value = Op Value ! (N&31)<<7 ! litsh(Sh)
 1833           %else
 1834              Register(Rs)
 1835              Op Value = Op Value ! Rs<<8 ! regsh(Sh)
 1836           %finish
 1837        %end
 1838  
 1839  Ot(1):Key = Op Value>>23&3
 1840        N = Op Value>>21&15
 1841        Rn = 0;  Rd = 0;  Rm = 0; Rs = 0
 1842        %if Omatch('S') %start
 1843           Op Value = Op Value ! 1<<20
 1844        %finish
 1845        %if Omatch('P') %start
 1846           Warn(1, "spurious P qualifier") %unless Key = 2_10
 1847           Rd = 15
 1848        %finish
 1849        Register(Rn)
 1850        %if Key # 2_10 %start
 1851           Rd = Rn;  Rn = 0
 1852           %if N # 13 %and N # 15 %start
 1853              Comma
 1854              Register(Rn)
 1855           %finish
 1856        %finish
 1857        Op Value = Op Value ! Rd<<12 ! Rn<<16
 1858        Comma
 1859        %if Match('#') %start
 1860           Want Literal(N)
 1861           Rot = 16
 1862           %if N # 0 %start
 1863              Rot = Rot-1 %and N = N>>2 %while N&3 = 0
 1864           %finish
 1865           Mc Error("cannot generate constant") %if N>>8 # 0
 1866           Op Value = Op Value ! (Rot&15)<<8 ! N ! 16_0200 0000
 1867        %else
 1868           Register(Rm)
 1869           Get Shift %if Match(',')
 1870           Op Value = Op Value ! Rm
 1871        %finish
 1872        ->OK
 1873  
 1874        %routine Get Displacement(%integer Mode)
 1875           %integer Rm
 1876           Ud = 1
 1877           %if Match('#') %start
 1878              Want Literal(Disp)
 1879              Ud = 0 %and Disp = -Disp %if Disp < 0
 1880           %else
 1881              Disp = 0
 1882              %if Match('-') %start
 1883                 Ud = 0
 1884              %else %if Match('+')
 1885              %finish
 1886              Register(Rm)
 1887              Op Value = Op Value ! Rm ! 16_0200 0000
 1888              Get Shift %if Match(',')
 1889           %finish
 1890           Op Value = Op Value ! Mode
 1891        %end
 1892  
 1893        %routine Modify Disp
 1894           %integer Sign, Mod
 1895           Sign = Pending
 1896           %return %unless Match('+') %or Match('-')
 1897           Mc Error("constant expected") %unless Literal(Mod)
 1898           Mod = -Mod %if Sign = '-'
 1899           N = N+Mod
 1900        %end
 1901  
 1902  Ot(2):%if Omatch('B') %start
 1903           Op Value = Op Value ! 1<<22   {byte value}
 1904        %finish
 1905        %if Omatch('T') %start
 1906           Op Value = Op Value ! 1<<21   {translate bit}
 1907        %finish
 1908        Register(Rd)
 1909        Op Value = Op Value ! Rd<<12
 1910        Comma
 1911        Ud = 1
 1912        %if Match(' ') %start          {a defined object}
 1913           W == Var(Tag)
 1914           Disp = W_Disp
 1915           Modify Disp
 1916           %if W_Base = Local %start
 1917              Rn = Actual(Fp)
 1918           %else %if W_Base = SB
 1919              Rn = Actual(Sb)
 1920           %else %if W_Base = 0 %and W_Area < 0
 1921              Dir3(Dir Spec Load, Rd, -W_Area)
 1922              Refs = Refs+1;  Ca = Ca+4
 1923              Rn = Rd
 1924              Disp = 0
 1925           %finish %else Mc Error("cannot address non-locals")
 1926           Disp = -Disp %and Ud = 0 %if Disp < 0
 1927           Op Value = Op Value ! 16_0500 0000 ! Rn<<16
 1928        %else
 1929           Want('[')
 1930           Register(Rn)
 1931           Op Value = Op Value ! Rn<<16
 1932           %if Match(',') %start      { [Rn, D] }
 1933              Warn(1, "spurious translate option") %if Op Value&(1<<21) # 0
 1934              Get Displacement(16_0500 0000)
 1935              Want(']')
 1936              Op Value = Op Value ! 1<<21 %if Match('!')
 1937           %else
 1938              Want(']')
 1939              %if Match(',') %start   { [Rn], D }
 1940                 Get Displacement(16_0400 0000)
 1941              %else                    { [Rn]    }
 1942                 Disp = 0
 1943                 Op Value = Op Value ! 16_0400 0000
 1944              %finish
 1945           %finish
 1946        %finish
 1947        Mc Error("displacement too large") %if Disp > 4095
 1948        Op Value = Op Value ! Ud<<23 ! Disp
 1949        ->OK
 1950  
 1951     {Trap}
 1952  
 1953  Ot(3):Want Literal(N);  Op Value = Op Value ! N&16_00FF FFFF;  ->OK
 1954  
 1955     {Block data manipulation}
 1956  
 1957        %routine Rlist
 1958           Want('<')
 1959           %unless Pending = '>' %start
 1960              %cycle
 1961                 Register(N)
 1962                 Op Value = Op Value ! 1<<N
 1963              %repeat %until %not Match(',')
 1964           %finish
 1965           Want('>')
 1966        %end
 1967  
 1968  Ot(4):%if Omatch('I') %start
 1969           %if Omatch('A') %start
 1970              Op Value = Op Value ! 2_01<<23
 1971           %else %if Omatch('B')
 1972              Op Value = Op Value ! 2_11<<23
 1973           %else
 1974              Mc Error("IA or IB expected")
 1975           %finish
 1976        %else %if Omatch('D')
 1977           %if Omatch('A') %start
 1978              Op Value = Op Value ! 2_00<<23
 1979           %else %if Omatch('B')
 1980              Op Value = Op Value ! 2_10<<23
 1981           %else
 1982              Mc Error("DA or DB expected")
 1983           %finish
 1984        %else
 1985           %if Omatch('F') %start
 1986              Op Value = Op Value ! 2_10<<23
 1987           %else %if Omatch('E')
 1988              Op Value = Op Value ! 2_00<<23
 1989           %finish
 1990           %if Omatch('A') %start
 1991              Op Value = Op Value ! 2_01<<23
 1992           %else %if Omatch('D')
 1993              Op Value = Op Value ! 2_00<<23
 1994           %finish
 1995        %finish
 1996        Register(Rn)
 1997        Op Value = Op Value ! Rn<<16
 1998        Op Value = Op Value ! 1<<21 %if Match('!')  {writeback}
 1999        Comma
 2000        Rlist
 2001        Op Value = Op Value ! 1<<22 %if Match('^')  {set PSR}
 2002        ->OK
 2003  
 2004  Ot(5):%if Match(' ') %start          {a defined object}
 2005           W == Var(Tag)
 2006           %if W_Type = Labels %start
 2007              Dir3(Dir McLabel, W_Disp, Op Value)
 2008              Ca = Ca+4
 2009              ->Done
 2010           %finish
 2011        %finish
 2012        Mc Error("Unimplemented form of branch")
 2013  
 2014        %routine Set DS(%integer Let P)
 2015           %if Omatch('D') %start
 2016              Op Value = Op Value ! 16_0000 0080
 2017           %else %if Omatch('E')
 2018              Op Value = Op Value ! 16_0008 0000
 2019           %else %if Let P # 0 %and Omatch('P')
 2020              Op Value = Op Value ! 16_0008 0080
 2021           %else %unless Omatch('S')
 2022              McError("D, S, E or P wanted")
 2023           %finish
 2024        %end
 2025  
 2026        %routine Lit Reg(%integername R)
 2027           %if Match('#') %start
 2028              Want Literal(R)
 2029              %if R = 1 %and Match('/') %start
 2030                 Want Literal(R)
 2031                 McError("only 1/2 permitted") %if R # 2
 2032                 R = 6
 2033              %else
 2034                 McError("bad range") %unless 0 <= R <= 5 %or R = 10
 2035                 R = 7 %if R = 10
 2036              %finish
 2037              R = R ! 8
 2038           %else
 2039              F Register(R);  R = R&7
 2040           %finish
 2041        %end
 2042  
 2043  Ot(6):   %if Omatch('S') %start
 2044           %else %if Omatch('D')
 2045              Op Value = Op Value ! 2_000000000 0 000000 1 000000000000000
 2046           %else %if Omatch('E')
 2047              Op Value = Op Value ! 2_000000000 1 000000 0 000000000000000
 2048           %else %if Omatch('P')
 2049              Op Value = Op Value ! 2_000000000 1 000000 1 000000000000000
 2050           %finish
 2051           F Register(Fdst);  Comma
 2052           Ud = 1
 2053           %if Match(' ') %start          {a defined object}
 2054              W == Var(Tag)
 2055              Disp = W_Disp
 2056              Modify Disp
 2057              %if W_Base = Local %start
 2058                 Rn = Actual(Fp)
 2059              %else %if W_Base = SB
 2060                 Rn = Actual(Sb)
 2061              %else %if W_Base = 0 %and W_Area < 0
 2062                 Dir3(Dir Spec Load, Rd, -W_Area)
 2063                 Refs = Refs+1;  Ca = Ca+4
 2064                 Rn = Rd
 2065                 Disp = 0
 2066              %finish %else Mc Error("cannot address non-locals")
 2067           %else
 2068              Want('[')
 2069              Register(Rn)
 2070              %if Match(',') %start      { [Rn, D] }
 2071                 Warn(1, "spurious translate option") %if Op Value&(1<<21) # 0
 2072                 Get Displacement(16_0500 0000)
 2073                 Want(']')
 2074                 Op Value = Op Value ! 1<<21 %if Match('!')
 2075              %else
 2076                 Want(']')
 2077                 %if Match(',') %start   { [Rn], D }
 2078                    Get Displacement(16_0400 0000)
 2079                 %else                    { [Rn]    }
 2080                    Op Value = Op Value ! 16_0400 0000
 2081                 %finish
 2082              %finish
 2083           %finish
 2084           Disp = -Disp %and Ud = 0 %if Disp < 0
 2085           Mc Error("Alignment error") %if Disp&3 # 0
 2086           Disp = Disp>>2
 2087           Mc Error("displacement too large") %if Disp > 255
 2088           Op Value = Op Value ! Disp ! 16_0500 0000 ! Rn<<16 %c
 2089+                              ! (Fdst&7)<<12 ! Ud<<23
 2090           ->OK
 2091  
 2092           %routine Set Round
 2093              %if Omatch('P') %start
 2094                 Op Value = Op Value ! 16_0000 0020
 2095              %else %if Omatch('M')
 2096                 Op Value = Op Value ! 16_0000 0040
 2097              %else %if Omatch('Z')
 2098                 Op Value = Op Value ! 16_0000 0060
 2099              %finish
 2100           %end
 2101  
 2102  Ot(7):   Set DS(0)
 2103           Set Round
 2104           N = Op Value>>20&15
 2105           %if N = 0  %start      {flt}
 2106              F Register(Reg1);  Comma;  Register(Reg2)
 2107              Op Value = Op Value ! (Reg1&7)<<16 ! Reg2<<12
 2108           %else %if N = 1        {fix}
 2109              Register(Reg1);  Comma;  F Register(Reg2)
 2110              Op Value = Op Value ! (Reg1)<<12 ! Reg2&7
 2111           %else
 2112              Register(Reg1)
 2113              Op Value = Op Value ! Reg1<<12
 2114           %finish
 2115           ->OK
 2116  
 2117  Ot(9):   F Register(Fs1);  Comma;  Lit Reg(Fs2)
 2118           Op Value = Op Value ! (Fs1&7)<<16 ! Fs2
 2119           ->OK
 2120  
 2121  Ot(10):  Set DS(1)
 2122           Set Round
 2123           F Register(Fdst);  Comma
 2124           %if Op Value&16_0000 8000 = 0 %start     {dyadic}
 2125              F Register(Fs1);   Comma
 2126           %else                                    {monadic}
 2127              Fs1 = 0
 2128           %finish
 2129           Lit Reg(Fs2)
 2130           Op Value = Op Value ! (Fdst&7)<<12 ! (Fs1&7)<<16 ! Fs2
 2131           ->OK
 2132  
 2133  Ot(-1):  %cycle
 2134              Mc Error("constant expected") %unless Literal(N)
 2135              %if Op Num = -1 %start
 2136                 Dump Byte(N&255)
 2137              %else %if Op Num = -2
 2138                 Dump Byte(N&255)
 2139                 Dump Byte(N>>8&255)
 2140              %else
 2141                 Dump Word(N)
 2142              %finish
 2143           %repeat %until %not Match(',')
 2144           %if Ca&3 # 0 %start
 2145              Dump Byte(0) %until Ca&3 = 0
 2146              Warn(0, "zero padding bytes added to ensure word alignment")
 2147           %finish
 2148           ->Done
 2149  
 2150  OK:   Dump Word(Op Value)
 2151  Done: Mc Error("Too many operands") %unless Match(';')
 2152        Mc Error("spurious operation qualifiers") %if SymP # Op Length
 2153     %finish
 2154  %end
?SH unused
?X unused
?P unused
?J unused
?OPERANDS unused
 2155  !%endoffile
 2156  !##########################################################################
 2157  
 2158  %integerfn Uses(%integer R, %record(Stackfm)%name V)
 2159     %integer N = 0
 2160     %while V ## Nil %cycle
 2161        N = N+1 %if V_Base = R
 2162        N = N+Uses(R, V_Index) %unless V_Index == Nil
 2163        N = N+Uses(R, V_Record) %unless V_Record == Nil
 2164        V == V_Link
 2165     %repeat
 2166     %result = N
 2167  %end
 2168  
 2169  %routine Store Real Constant(%record(Stackfm)%name W)
 2170     %integer N
 2171     %if W_Form = Address %and W_Base = 0      %c
 2172+                         %and W_Record == Nil %c
 2173+                         %and W_Index == Nil %start    {real constant}
 2174        Constant Base = (Constant Base+3)&(\3)
 2175        Select Constant Area
 2176        N = Ca
 2177        Dump Word(W_Rhigh)
 2178        Dump Word(W_Rlow)
 2179        Select Code Area
 2180        W_Disp = N;  W_Area = Constant Area;  W_Form = Direct
 2181     %finish
 2182  %end
 2183  
 2184  %predicate Potentially Unassigned(%record(Stackfm)%name V)
 2185     %false %if Unassigned = 0
 2186     %false %if V_Flags&Known Ass # 0
 2187     %false %unless V_Form = Direct %and V_Flags&Checkable # 0
 2188     %true
 2189  %end
 2190  
 2191  %routine Simple(%record(Stackfm)%name From, To)
 2192     %record(Stackfm)%name W
 2193     W == Copy(From)
 2194     Move(W, To)
 2195     Release and Drop(W)
 2196  %end
 2197  
 2198  %routine Load Address(%record(Stackfm)%name V, %integer R)
 2199     Amap(V)
 2200     Load(V, R)
 2201  %end
 2202  
 2203  %routine Push(%record(Stackfm)%name V)
 2204     %record(Stackfm) S = 0
 2205     S_Type = Integers;  S_Form = AutoD;  S_Base = SP
 2206     Store(V, S)
 2207  %end
 2208  
 2209  %routine Push Literal(%integer Lit)
 2210     %record(Stackfm)%name L == Literal(Lit)
 2211     Push(L)
 2212     Release and Drop(L)
 2213  %end
 2214  
 2215  %routine Push Address(%record(Stackfm)%name V)
 2216     Amap(V)
 2217     Push(V)
 2218  %end
 2219  
 2220  %routine Pop Stack(%integer Bytes)
 2221     %return %if Bytes = 0
 2222     Fail("stack alignment") %if Bytes&3 # 0
 2223     Plant1(ADD, Sp, Sp, Rot(Bytes>>2, 16-1))
 2224  %end
 2225  
 2226  %routine Loadup Address(%record(Stackfm)%name V)
 2227     Amap(V)
 2228     Load(V, Any)
 2229  %end
 2230  
 2231  %routine Loadup(%record(Stackfm)%name From)
 2232     %integer Oper
 2233     %record(stackfm)%name W, Lhs
 2234     %if From_Type = Sets %start
 2235        Fail("Bad set") %if From_Oper = 0
 2236        Oper = From_Oper;  W == From_Link;  From_Oper = 0;  From_Link == NIL
 2237        %if From_Flags&Work Set = 0 %start
 2238           Lhs == Claim Work Area(Set Size, Sets);  Lhs_Flags = Lhs_Flags!Work Set
 2239           Set Assign(From, Lhs)
 2240           Release(From_Base)
 2241           Zap Index and Record(From)
 2242           From_Data = Lhs_Data
 2243           Drop(Lhs)
 2244        %finish
 2245        Lhs == Copy(From)
 2246        From_Oper = Oper;  From_Link == W
 2247        Set Assign(From, Lhs)
 2248        Release and Drop(Lhs)
 2249     %else %if Floating(From)
 2250        Load(From, AnyF)
 2251     %else
 2252        Load(From, Any)
 2253     %finish
 2254  %end
 2255  
 2256  %routine Load Protected(%record(Stackfm)%name V)
 2257     {load V somewhere it can be altered safely}
 2258     Monitor(V, "->Load protected") %if Diag&MonOperand # 0
 2259     Loadup(V)
 2260     %if Activity(V_Base) # 1 %start    {covers in use (>1) and locked (<0)}
 2261        %if V_Type >= Reals %then Load(V, FPR) %else Load(V, GPR)
 2262     %finish
 2263     Monitor(V, "<-Load protected") %if Diag&MonOperand # 0
 2264  %end
 2265  
 2266  %routine Constant Operation(%integer Op, %integername L,
 2267+                                          %record(Stackfm)%name R)
 2268        %switch Cop(NOTX:REXPX)
 2269        %integer N
 2270        N = R_Disp;  Drop(R)
 2271        ->Cop(Op)
 2272  Cop(ADDX):                                    L = L+N;        ->Out
 2273  Cop(SUBX):                                    L = L-N;        ->Out
 2274  Cop(MULHx):
 2275  Cop(MULX):                                    L = L*N;        ->Out
 2276  Cop(ANDx):                                    L = L&N;        ->Out
 2277  Cop(BICx):                                    L = L&(\N);     ->Out
 2278  Cop( ORX):                                    L = L!N;        ->Out
 2279  Cop(XORX):                                    L = L!!N;       ->Out
 2280  Cop(LSHX):                                    L = L<<N;       ->Out
 2281  Cop(RSHX):                                    L = L>>N;       ->Out
 2282  Cop(EXPX):   Fail("Exp") %if N < 0;           L = L\\N;       ->Out
 2283  Cop(MODx):   Fail("Illegal MOD") %if N <= 0
 2284               %if L < 0 %start
 2285                  L = N-Rem(-L, N);  L = 0 %if L = N;           ->Out
 2286               %finish
 2287  Cop(REMx):   Fail("Zero divide")  %if N = 0;  L = Rem(L, N);  ->Out
 2288  Cop(DIVX):   Fail("Zero divide")  %if N = 0;  L = L//N;       ->Out
 2289  Cop(*):      Fail("C-op")
 2290  Out:
 2291  %end
 2292  
 2293  %routine Operate(%integer NewOper, %record(Stackfm)%name Lhs, Rhs)
 2294     %integer Op, Rconst, Key, Lflags, Rflags, N, Fn
 2295     %record(Stackfm)%name W
 2296  
 2297     %routine Swop
 2298        %record(Stackfm) Temp
 2299        Temp_Data = Lhs_Data
 2300         Lhs_Data =  Rhs_Data
 2301         Rhs_Data = Temp_Data
 2302     %end
 2303  
 2304     %routine Zap
 2305        {Make LHS = integer constant 0}
 2306        Drop(W)
 2307        Drop(Rhs)
 2308        Lhs_Link == Nil;  Lhs_Oper = 0
 2309        Rhs == Literal(0);  Swop;  Release and Drop(Rhs)
 2310     %end
 2311  
 2312     %routine Reduce Constant
 2313        %integer Op, N, F
 2314  
 2315        %routine Fix(%integer Op)
 2316           Lhs_Oper = Op
 2317           Drop(Lhs_Link)
 2318           Lhs_Link == Nil
 2319        %end
 2320  
 2321        Op = Lhs_Oper;  F = Oper Flags(Op)
 2322        N = Lhs_Link_Disp
 2323        %if F&Nullop # 0 %and Null Value(Op) = N %start
 2324           Fix(0)
 2325        %else %if Op = MULx
 2326           %if N = 0 %start
 2327              Fix(0)
 2328              Release(Lhs_Base)
 2329              Lhs_Form = Address;  Lhs_Base = None;  Lhs_Disp = 0;  Lhs_Area = 0
 2330              Release and Drop(Lhs_Index) %if Lhs_Index ## Nil
 2331              Release and Drop(Lhs_Record) %if Lhs_Record ## Nil
 2332              Lhs_Record == Nil;  Lhs_Index == Nil
 2333           %else %if N = -1
 2334              Fix(NEGX)
 2335           %finish
 2336        %else %if Op = ADDx
 2337          %if Lhs_Form = Address %start
 2338              Fix(0);  Lhs_Disp = Lhs_Disp+N
 2339          %finish
 2340        %else %if Op = ANDx %and Lhs_Form = Direct %and Lhs_Area = 0
 2341           N = N&255 %if Lhs_Type = Bytes
 2342           %if Unassigned = 0 %or Lhs_Flags&Checkable = 0 %c
 2343+                             %or Lhs_Flags&Known Ass # 0 %start
 2344              {only do this if Lhs is not to be checked for unassigned}
 2345              %if       N&16_FFFFFF00 = 0 %start
 2346                 Lhs_Type = Bytes
 2347                 Fix(0) %if N = 255
 2348              %else %if N&16_FFFF00FF = 0 %and Lhs_Type = Shorts
 2349                 Lhs_Type = Bytes;  Lhs_Disp = Lhs_Disp+1
 2350                 N = N>>8;  Lhs_Link_Disp = N
 2351                 Fix(0) %if N = 255
 2352                 Operate(LSHx, Lhs, Literal(8))
 2353              %finish
 2354           %finish
 2355        %else %if Op = XORX %and N = -1
 2356           Fix(NOTX)
 2357        %finish
 2358     %end
 2359  
 2360     %integerfn Field(%integer And, Shift, AndFirst)
 2361        %integer R = 0
 2362        %if AndFirst # 0 %start              {X&And >> Shift}
 2363           And = (And>>Shift)<<Shift
 2364           %result = -1 %if And = 0          {zero result}
 2365           And = And>>1 %and R = R+1 %while And&1 = 0
 2366           %result = 0 %if Shift < R         {shift must equal R}
 2367                                             {it's now in the form X>>Shift & And}
 2368        %else                                {X>>Shift & And}
 2369           And = (And<<Shift)>>Shift
 2370           %result = -1 %if And = 0          {zero result}
 2371        %finish
 2372        N = Power(And+1);  %result = 0 %if N < 0 %or N > 8
 2373        %result = N<<16 + Shift
 2374     %end
 2375  
 2376     %if Diag&MonOperate # 0 %start
 2377        Monitor(Lhs, "O-Lhs")
 2378        Monitor(Rhs, "O-Rhs")
 2379     %finish
 2380     Rflags = Oper Flags(NewOper)
 2381     %if Rflags&Unary # 0 %start
 2382        %if Iconst(Lhs) %start                 {this excludes reals}
 2383           %if NewOper = NEGX %start
 2384              Lhs_Disp = -Lhs_Disp
 2385           %else %if NewOper = NOTX
 2386              Lhs_Disp = \Lhs_Disp
 2387           %else %if NewOper = ABSx
 2388              Lhs_Disp = |Lhs_Disp|
 2389           %finish %else Fail("Operator")
 2390        %else
 2391           NewOper = NewOper+Real Shift %if Floating(Lhs)
 2392           %if Lhs_Oper # 0 %start
 2393              %if Lhs_Oper = NewOper %start      {e.g. -(-A) }
 2394                 {SCR/87/401}
 2395                 Lhs_Oper = 0 %unless NewOper = ABSx %c
 2396+                                 %or NewOper = RABSx  {BEWARE: ABS(ABS(X))}
 2397                 ->Mon
 2398              %finish
 2399              %if NewOper = NEGx %or NewOper = NOTx %start  {SCR/87/401}
 2400                 %if Lhs_Oper = NEGx %or Lhs_Oper = NOTx %start
 2401                    { -(\A)  ->  A+1      Note:  -NEG = ADD }
 2402                    { \(-A)  ->  A-1             -NOT = SUB }
 2403                    Lhs_Oper = 0
 2404                    %if NewOper = NEGx %then NewOper = ADDx %else NewOper = SUBx
 2405                    Operate(NewOper, Lhs, Literal(1))
 2406                    ->Mon
 2407                 %finish
 2408              %finish
 2409              %if NewOper = NEGx %and Lhs_Oper = MULx %and Iconst(Lhs_Link) %start
 2410                 %if Lhs_Link_Disp # Minus Infinity %start
 2411                    Lhs_Link_Disp = -Lhs_Link_Disp
 2412                    ->Mon
 2413                 %finish
 2414              %finish
 2415              Loadup(Lhs)
 2416           %finish
 2417           Lhs_Oper = NewOper;  Lhs_Link == Nil
 2418        %finish
 2419        ->Mon
 2420     %finish
 2421  
 2422     %if NewOper = ConcX %start
 2423        %if Rhs_Bias = 1 %start                  {s.""}
 2424           Drop(Rhs);  %return
 2425        %finish
 2426        %if Lhs_Bias = 1 %start                  {"".S}
 2427           Fail("inconsistent concatenation") %if Lhs_Link ## Nil
 2428           Lhs_Data = Rhs_Data;  Drop(Rhs)
 2429           %return
 2430        %finish
 2431        Loadup(Lhs) %if Lhs_Oper # 0 %and Lhs_Oper # CONCx
 2432        Loadup(Rhs) %if Rhs_Oper # 0
 2433        Lhs == Lhs_Link %while Lhs_Oper # 0      {skip to the end}
 2434        Lhs_Oper = ConcX;  Lhs_Link == Rhs       {append the new bit}
 2435        ->Mon
 2436     %finish
 2437  
 2438     Swop %if Rflags&Commutative # 0 %and Iconst(Lhs) {1@? -> ?@1}
 2439  
 2440     %if Rhs_Oper # 0 %start
 2441        Op = Rhs_Oper
 2442        %if Op = NEGx %and (NewOper = ADDx %or NewOper = SUBx) %start
 2443                                                    { Lhs + (-Rhs) }
 2444           NewOper = (ADDx+SUBx)-NewOper            { Lhs - Rhs }
 2445           Rflags = Oper Flags(NewOper)
 2446           Rhs_Oper = 0
 2447        %else %if Op = NOTx %and NewOper = ANDx     {convert to BIC}
 2448           Rhs_Oper = 0;  NewOper = BICx
 2449        %else %if (Op = LSHx %or Op = RSHx) %and Oper Flags(NewOper)&Easy # 0 %c
 2450+                                           %and Lhs_Type < Reals             %c
 2451+                                           %and Lhs_Oper < Rnegx
 2452           {optimise A newoper B shift C}
 2453           W == Rhs_Link;  Rhs_Link == NIL;  Rhs_Oper = 0
 2454           Loadup(Lhs)
 2455           Loadup(Rhs)
 2456           %if Iconst(W) %start
 2457              %if Op = LSHx %then N = Ishift(Rhs_Base, W_Disp, Logical Left) %c
 2458+                           %else N = Ishift(Rhs_Base, W_Disp, Logical Right)
 2459           %else
 2460              Loadup(W)
 2461              %if Op = LSHx %then N = Rshift(Rhs_Base, W_Base, Logical Left R) %c
 2462+                           %else N = Rshift(Rhs_Base, W_Base, Logical Right R)
 2463           %finish
 2464           Plant1(Easy Op(NewOper), Lhs_Base, Lhs_Base, N)
 2465           Release and Drop Pair(Rhs, W)
 2466           %return
 2467        %else
 2468           Loadup(Rhs)
 2469        %finish
 2470     %finish
 2471  
 2472     %if Iconst(Rhs) %start
 2473        Rconst = 1
 2474        %if NewOper = SUBX %start                    { Lhs-(+const) }
 2475           %if Rhs_Disp # Minus Infinity %start
 2476              Rhs_Disp = -Rhs_Disp
 2477              NewOper = ADDx                            { Lhs+(-const) }
 2478              Rflags = Oper Flags(ADDx)
 2479           %finish
 2480        %finish
 2481        %if Oper Flags(NewOper)&Nullop # 0 %and Null Value(NewOper) = Rhs_Disp %start
 2482           Drop(Rhs)
 2483           %return
 2484        %finish
 2485     %else
 2486        Rconst = 0
 2487     %finish
 2488  
 2489     %if Lhs_Oper # 0 %start
 2490        Op = Lhs_Oper;  Lflags = Oper Flags(Op)
 2491        W == Lhs_Link
 2492        %if Op = NEGx %and NewOper = MULx %start
 2493           Lhs_Oper = 0
 2494           Operate(MULx, Lhs, Rhs)
 2495           Operate(NEGx, Lhs, Nil)
 2496           %return
 2497        %finish
 2498        %if Lflags&Unary = 0 %and Iconst(W) %start
 2499           %if Rconst # 0 %and NewOper < RNEGx %start
 2500              Key = (Lflags!Rflags)&Assoc Mask
 2501              %if Key = 0          {strongly associative} %or %c
 2502+                (Key = Weak Assoc {weakly associative}   %and NewOper = Op) %start
 2503                 %if Rhs_Base = None %or NewOper = ADDX %start
 2504                    Constant Operation(NewOper, W_Disp, Rhs)
 2505                    Reduce Constant %if Rhs_Base = None
 2506                    ->Mon
 2507                 %finish
 2508              %finish
 2509              %if Op = LSHx %and NewOper = ANDx %and -31 <= W_Disp <= 0 %start
 2510                 N = Field(Rhs_Disp, -W_Disp, 0)
 2511                 %if N # 0 %start
 2512                    Zap %and ->Mon %if N = -1
 2513                    W_Disp = N;  Lhs_Oper = EXTx
 2514                    Drop(Rhs)
 2515                    ->Mon
 2516                 %finish
 2517              %finish
 2518              %if Op = ANDx %and NewOper = RSHx %and 0 <= Rhs_Disp <= 31 %start
 2519                 N = Field(W_Disp, Rhs_Disp, 1)
 2520                 %if N # 0 %start
 2521                    Zap %and ->Mon %if N = -1
 2522                    W_Disp = N
 2523                    Lhs_Oper = EXTx
 2524                    Drop(Rhs)
 2525                    ->Mon
 2526                 %finish
 2527              %finish
 2528  !!            %if Op = ADDx %and NewOper = MULx %start     { (A+c)*m -> Am+cm }
 2529  !!               W_Disp = W_Disp*Rhs_Disp
 2530  !!               Lhs_Link == Nil;  Lhs_Oper = 0
 2531  !!               Operate(MULx, Lhs, Rhs)
 2532  !!               Operate(ADDx, Lhs, W)
 2533  !!               %return
 2534  !!            %finish
 2535           %finish
 2536        %finish
 2537        %if (Op = LSHx %or Op = RSHx) %and Oper Flags(NewOper)&Easy # 0 %c
 2538+                                     %and NewOper # BICx               %c
 2539+                                     %and Rhs_Type < Reals %start
 2540           Lhs_Link == NIL;  Lhs_Oper = 0
 2541           Loadup(Lhs)
 2542           Loadup(Rhs)
 2543           %if Iconst(W) %start
 2544              %if Op = LSHx %then N = Ishift(Lhs_Base, W_Disp, Logical Left) %c
 2545+                           %else N = Ishift(Lhs_Base, W_Disp, Logical Right)
 2546           %else
 2547              Loadup(W)
 2548              %if Op = LSHx %then N =Rshift(Lhs_Base, W_Base, Logical LeftR) %c
 2549+                           %else N =Rshift(Lhs_Base, W_Base, Logical RightR)
 2550           %finish
 2551           Fn = Easy Op(NewOper)
 2552           Fn = RSB %if NewOper = SUBx     {not commutative}
 2553           Plant1(Fn, Rhs_Base, Lhs_Base, N)
 2554           Release and Drop Pair(Rhs, W)
 2555           %return
 2556        %finish
 2557        Loadup(Lhs)                           {no other choice}
 2558     %finish
 2559  
 2560     %if Iconst(Lhs) %and Rconst # 0 %and NewOper < RNEGx %start
 2561        Constant Operation(NewOper, Lhs_Disp, Rhs)
 2562        ->Mon
 2563     %finish
 2564  
 2565     %if Lhs_Type >= Reals %or Rhs_Type >= Reals %start
 2566        NewOper = NewOper+Real Shift %unless NewOper >= RNEGx
 2567        %if Lhs_Type = Sets %start
 2568           %if Lhs_Flags = Null Set %start
 2569              Swop %if NewOper = RADDx               {keep the other set}
 2570              Rhs_Type = 0
 2571           %else %if Rhs_Flags = Null Set
 2572              Swop %if NewOper = RMULx               {keep the null set}
 2573              Rhs_Type = 0
 2574           %finish
 2575           Lhs_Oper = NewOper;  Lhs_Link == Rhs
 2576           %if Rhs_Type = 0 %start
 2577              Lhs_Oper = 0;  Lhs_Link == Nil
 2578              Drop Members(Rhs);  Release and Drop(Rhs)
 2579           %finish
 2580           ->Mon
 2581        %finish
 2582     %finish
 2583  
 2584     %if Rflags&Commutative # 0 %and InReg(Rhs) %start
 2585        Swop
 2586        Rconst = 0
 2587        Rconst = 1 %if Iconst(Rhs)
 2588     %finish
 2589     %if NewOper = SUBx %and Lhs_Form  = Address = Rhs_Form %start
 2590        {try to optimise addr(x) - addr(y)}
 2591        %if Lhs_Base = Rhs_Base %and Lhs_Area = Rhs_Area %start
 2592           %if Same(Lhs_Index, Rhs_Index) %and Same(Lhs_Record, Rhs_Record) %c
 2593+                                         %and Lhs_Xsize = Rhs_Xsize %start
 2594              Lhs_Disp = Lhs_Disp - Rhs_Disp
 2595              Release and Drop(Rhs)
 2596              Release and Drop(Lhs_Index) %if Lhs_Index ## Nil
 2597              Release and Drop(Lhs_Record) %if Lhs_Record ## Nil
 2598              Lhs_Base  = 0
 2599              Lhs_Xsize = 0
 2600              ->Mon
 2601           %finish
 2602        %finish
 2603     %finish
 2604     Lhs_Oper = NewOper;  Lhs_Link == Rhs
 2605     Reduce Constant %if Rconst # 0
 2606  Mon:
 2607     Monitor(Lhs, "<-Operate") %if Diag&MonOperate # 0
 2608  %end
 2609  
 2610  %routine Aop
 2611     %integer Type, Format, Size
 2612     %record(Stackfm)%name X
 2613     X     == Stack                               {index value}
 2614     Stack == X_Stack                             {the base item}
 2615     Size = Item Size(Stack_Format)
 2616     %if Stack_Index == Nil %start
 2617        Stack_Index == X;  Stack_Xsize = Size
 2618     %else %if Stack_Xsize = Size
 2619        Operate(ADDx, Stack_Index, X)
 2620     %else
 2621        Type   = Stack_Type;  Format = Stack_Format
 2622        Amap(Stack)
 2623        Operate(MULx, X, Literal(Size))
 2624        Operate(ADDx, Stack, X)
 2625        Vmap(Stack, Type);  Stack_Format = Format
 2626     %finish
 2627  %end
 2628  
 2629  %routine Operation(%integer Oper)
 2630     %record(Stackfm)%name V
 2631     V     == Stack
 2632     Stack == Stack_Stack
 2633     Operate(Oper, Stack, V)
 2634  %end
 2635  
 2636  %routine Replace(%record(Stackfm)%name Old, New)
 2637     Zap Index and Record(Old)
 2638     Release(Old_Base)
 2639     Old_Base   = New_Base
 2640     Old_Disp   = New_Disp
 2641     Old_Extra  = New_Extra
 2642     Old_Type   = New_Type
 2643     Old_Form   = New_Form
 2644     Old_Format = New_Format
 2645     Old_Area   = New_Area
 2646     Old_Oper   = 0
 2647     Old_Link  == Nil
 2648     Drop(New)
 2649  %end
 2650  
 2651  {***Register optimisation routines***}
 2652  
 2653  %predicate Memorable(%record(Stackfm)%name V, %record(Knowfm)%name K)
 2654     %integer Op = 0, Scale = 0
 2655     %if V_Oper # 0 %start
 2656        %false %unless V_Link ## Nil %and Iconst(V_Link)
 2657        Op    = V_Oper
 2658        Scale = V_Link_Disp
 2659     %finish
 2660     %false %if V_Index ## Nil %or V_Record ## Nil %or V_Form >= Memorable Limit
 2661     K_Ftype = V_Type<<4+V_Form
 2662     K_Base  = V_Base
 2663     K_Disp  = V_Disp
 2664     K_Extra = V_Extra
 2665     K_Area  = V_Area
 2666     K_Opnd  = Scale
 2667     K_Oper  = Op
 2668     K_Ftype = Integers<<4 + Address %if Iconst(V)
 2669     %true
 2670  %end
 2671  
 2672  %routine Optimise(%record(Stackfm)%name V, %integer Swanted)
 2673     {Swanted = 0 if destination (address) wanted}
 2674     {        = 1 if source (value) wanted}
 2675     %record(Knowfm)%name P
 2676     %record(Knowfm) M
 2677     %record(Stackfm)%name W
 2678     %integer Op
 2679  
 2680  
 2681     P == Knowing;  %return %if P == Nil        {nothing known}
 2682  
 2683     %if V_Oper # 0 %start
 2684        Op = V_Oper;  V_Oper = 0
 2685        W == V_Link;  V_Link == Nil
 2686        Optimise(V, 1)
 2687        Optimise(W, 1) %unless W == Nil
 2688        V_Oper = Op;  V_Link == W
 2689     %finish
 2690  
 2691     %if V_Record ## Nil %start
 2692        Optimise(V_Record, 1)
 2693        %if V_Record_Form = Address %start
 2694           Simplify(V)
 2695           P == Knowing;  %return %if P == Nil        {nothing known}
 2696        %finish
 2697     %finish
 2698     %return %unless Memorable(V, M)             {worth looking for?}
 2699     Monitor(V, "Opt") %if Diag&MonOpt # 0
 2700  
 2701        %routine Set(%integer Form)
 2702           %if V_Oper # 0 %start
 2703              Release and Drop(V_Link)
 2704              V_Oper = 0;  V_Link == Nil
 2705           %finish
 2706           V_Type = Integers %if Form = Address %and V_Type <= Addrs  {already expanded}
 2707           V_Form = Form
 2708           Release(V_Base)
 2709           V_Area = 0
 2710           V_Disp = 0;  V_Base = P_Reg
 2711           Pending Auto = 0 %if P_Reg = Pending Auto
 2712           Claim(V_Base)
 2713           Monitor(V, "Opt->") %if Diag&MonOpt # 0
 2714        %end
 2715  
 2716     %cycle
 2717        %if P_Disp  = M_Disp  %and P_Area = M_Area %and
 2718+           P_Extra = M_Extra %and P_Oper = M_Oper %and
 2719+           P_Base  = M_Base  %and P_Opnd = M_Opnd %start  {Basically ok}
 2720           %if P_Ftype = M_Ftype %and Swanted # 0 %start   {exact match}
 2721              Set(Address)
 2722              %return
 2723           %else %if M_Oper = 0 %and M_Ftype&15 # Address  {beware real zero}
 2724              %if P_Ftype = Integers<<4+Address %start     {we have the address}
 2725                 Set(V_Form)
 2726                 Optimise(V, 1) %if Swanted # 0
 2727                 %return
 2728              %finish
 2729           %finish
 2730        %finish
 2731        P == P_Link
 2732     %repeat %until P == Nil
 2733  %end
 2734  
 2735  %record(Knowfm)%map NewK
 2736     %record(Knowfm)%name P
 2737     P == Kasl
 2738     %if P == Nil %start
 2739        P == NEW(KnowfmType);  P = 0
 2740     %else
 2741        Kasl == P_Link
 2742     %finish
 2743     %result == P
 2744  %end
 2745  
 2746  %routine Kinc(%record(Knowfm)%name K)
 2747     Ktimes(K_Reg)  = Ktimes(K_Reg)+1
 2748     Ktimes(K_Base) = Ktimes(K_Base)+1 %if K_Base&128 = 0 {beware base registers}
 2749  %end
 2750  
 2751  %routine Kdec(%record(Knowfm)%name K)
 2752     Ktimes(K_Reg)  = Ktimes(K_Reg)-1
 2753     Ktimes(K_Base) = Ktimes(K_Base)-1 %if K_Base&128 = 0 {beware base registers}
 2754  %end
 2755  
 2756  %routine Forget(%integer Register)
 2757     %integername N
 2758     %record(Knowfm)%name K, R
 2759     %return %unless R0 <= Register <= F7
 2760     Pending Auto = 0 %if Pending Auto = Register
 2761     N == Ktimes(Register)
 2762     Used(Register) = 0
 2763     %return %if N = 0 {%or Activity(Register) < 0}    {004}
 2764     K == Knowing;  Knowing == Nil
 2765     %while K ## Nil %cycle
 2766        R == K;  K == K_Link
 2767        %if R_Reg = Register %or R_Base = Register %start
 2768           R_Link == Kasl;  Kasl == R
 2769           Kdec(R)
 2770           Mon Regid(R_Reg, "Forgotten") %if Diag&MonOpt # 0
 2771        %else
 2772           R_Link == Knowing;  Knowing == R      {retain it}
 2773        %finish
 2774     %repeat
 2775     Fail("Register still known") %if N # 0
 2776  %end
 2777  
 2778  %routine Forget Everything
 2779     %record(Knowfm)%name K
 2780     Pending Auto = 0
 2781     K == Knowing
 2782     %if K ## Nil %start
 2783        %cycle
 2784           Used(K_Reg)  = 0
 2785           Used(K_Base) = 0 %if K_Base&128 = 0    {beware of level bases}
 2786           Kdec(K)
 2787           %exit %if K_Link == Nil
 2788           K == K_Link
 2789        %repeat
 2790        K_Link == Kasl;  Kasl == Knowing
 2791        Knowing == NIL
 2792     %finish
 2793  %end
 2794  
 2795  %routine Inherit(%integer New, Old)
 2796     %record(Knowfm)%name P, K, X
 2797     %return %if New = Old
 2798     Used(New) = Used Time
 2799     P == Knowing
 2800     %while P ## Nil %cycle
 2801        K == P;  P == K_Link
 2802        %if K_Reg = Old %start
 2803           Mon Regid(Old, "inherited") %if Diag&MonOpt # 0
 2804           X == NewK;  %return %if X == Nil
 2805           X = K
 2806           X_Reg  = New
 2807           X_Link == Knowing;  Knowing == X
 2808           Kinc(X)
 2809        %finish
 2810     %repeat
 2811  %end
 2812  
 2813  %routine Remember(%integer Register, %record(Stackfm)%name V)
 2814     %record(Knowfm)%name K
 2815     %record(Knowfm) M
 2816     %return %unless R0 <= Register <= F7 %and Register # Any
 2817     Used(Register) = Used Time
 2818     %if InReg(V) %start             {inherit other register's data}
 2819        Inherit(Register, V_Base)
 2820        %return
 2821     %finish
 2822     %return %if Register = V_Base
 2823     %if Memorable(V, M) %start
 2824        K == NewK;  %return %if K == Nil
 2825        K = M
 2826        K_Reg = Register
 2827        K_Link == Knowing;  Knowing == K
 2828        Kinc(K)
 2829        Monitor(V, "Remember ".Regid(Register)) %if Diag&MonOpt # 0
 2830     %finish
 2831  %end
 2832  
 2833  %routine Remember Zero(%integer Register)
 2834     %record(Stackfm)%name Zero == Literal(0)
 2835     Forget(Register)
 2836     Remember(Register, Zero)
 2837     Drop(Zero)
 2838  %end
 2839  
 2840  %routine Forget Destination(%record(Stackfm)%name V)
 2841     %integer Low, High, Base = V_Base, Unsafe = 0, Alter
 2842     %record(Knowfm)%name P, K
 2843     Monitor(V, "Forget Dest") %if Diag&MonOpt # 0
 2844     Forget(V_Base) %and %return %if InReg(V)
 2845     Low = V_Disp;  High = Low+Item Size(V_Format)-1
 2846                    High = Low+3 %if High < Low
 2847     P == Knowing;  Knowing == Nil
 2848  
 2849     !
 2850     !  If generated a instruction of form STR _ Rx, y(Rz) then
 2851     !  should forget registers that hold non-address values.
 2852     !  Do not do this if trusted => trusted gets some progs wrong
 2853     !
 2854  
 2855     %if Interface_Options & LL Trusted = 0 %start
 2856        %if V_Base < 128 %and Activity(V_Base) >= 0 %start
 2857           Unsafe = 1
 2858        %else %if V_Index ## Nil 
 2859           Unsafe = 1
 2860        %finish
 2861        Monitor N(Unsafe, "Unsafe") %if Diag&MonOpt # 0
 2862     %finish
 2863  
 2864     %while P ## Nil %cycle
 2865        K == P;  P == P_Link
 2866        Alter = 0
 2867  
 2868        Alter = Unsafe %if K_Base < 128 %and Activity(K_Base) >= 0
 2869  
 2870        %if K_Ftype&15 # Address %start  {can remember addresses}
 2871           Alter = 1 %if K_Base = Base %and Low <= K_Disp <= High
 2872        %finish
 2873  
 2874        %if Alter # 0 %start
 2875           Kdec(K)
 2876           K_Link == Kasl;  Kasl == K
 2877           Mon Regid(K_Reg, "Altered") %if Diag&MonOpt # 0
 2878        %else
 2879           K_Link == Knowing;  Knowing == K  {remember it}
 2880        %finish
 2881     %repeat
 2882  %end
 2883  
 2884  {Environment handling}
 2885  
 2886  %routine Forget Environment(%integer Label)
 2887     %record(Labelfm)%name L
 2888     %record(Knowfm)%name P, E
 2889     L == Ilabel(Label)
 2890     P == L_Env;  L_Env == NIL
 2891     %if P ## NIL %start
 2892        E == P
 2893        P == P_Link %while P_Link ## NIL
 2894        P_Link == Kasl
 2895        Kasl == E
 2896     %finish
 2897  %end
 2898  
 2899  %routine Remember Environment(%integer Label)
 2900     %record(Knowfm)%name K, Top == NIL, P
 2901     Forget Environment(Label)
 2902     K == Knowing
 2903     %while K ## Nil %cycle
 2904        P == NewK              {cannot return Nil}
 2905        P = K
 2906        P_Link == Top
 2907        Top == P
 2908        Mon RegId(P_Reg, "in env") %if Diag&MonOpt # 0
 2909        K == K_Link               {onto the next item}
 2910     %repeat
 2911     Ilabel(Label)_Env == Top     {remember the start}
 2912  %end
 2913  
 2914  %routine Merge Environment(%integer Label)
 2915     {Update the saved environment of Label with the data in Knowing}
 2916     {Knowing is unaltered}
 2917     %record(Labelfm)%name L
 2918     %record(Knowfm)%name P, K, Next, Top
 2919     Monitor(Nil, "merge") %if Diag&MonOpt # 0
 2920     %if Knowing == Nil %start
 2921        Forget Environment(Label)
 2922     %else
 2923        L == Ilabel(Label)
 2924        Top == Nil
 2925        Next == L_Env
 2926        %cycle
 2927           P == Next;  %exit %if P == Nil
 2928           Next == P_Link
 2929           K == Knowing
 2930           %cycle
 2931              %if K_Reg   = P_Reg   %and                       %c
 2932+                 K_Disp  = P_Disp  %and K_Base = P_Base  %and %c
 2933+                 K_Ftype = P_Ftype %and K_Area = P_Area  %and %c
 2934+                 K_Opnd  = P_Opnd  %and K_Oper = P_Oper  %start
 2935                 P_Link == Top;  Top == P
 2936                 Mon RegId(P_Reg, "Merged") %if Diag&MonOpt # 0
 2937                 ->Found
 2938              %finish
 2939              K == K_Link
 2940           %repeat %until K == Nil
 2941           {Not Found}
 2942           P_Link == Kasl;  Kasl == P      {return the cell}
 2943  Found:%repeat
 2944        L_Env == Top
 2945     %finish
 2946  %end
 2947  
 2948  %routine Restore Environment(%integer Label)
 2949     %record(Knowfm)%name P, K, Next
 2950     Forget Everything              {dispose of old knowledge}
 2951     Next == Ilabel(Label)_Env
 2952     %cycle
 2953        P == Next;  %return %if P == NIL
 2954        Next == P_Link
 2955        K == NewK
 2956        K = P
 2957        K_Link == Knowing;  Knowing == K
 2958        Kinc(K)
 2959        Mon RegId(P_Reg, "back") %if Diag&MonOpt # 0
 2960     %repeat
 2961  %end
 2962  
 2963  {Register Control}
 2964  
 2965  %routine Claim(%integer Register)
 2966     %return %unless R0 <= Register <= AnyF %and Activity(Register) >= 0
 2967     Activity(Register) = Activity(Register)+1
 2968     Active Registers = Active Registers+1
 2969     Used Time = Used Time+1;  Used(Register) = Used Time
 2970     Monitor Register(Register, "Claimed") %if Diag&MonReg # 0
 2971  %end
 2972  
 2973  %routine Release(%integer Register)
 2974     %return %unless R0 <= Register <= AnyF %and Activity(Register) >= 0
 2975     Activity(Register) = Activity(Register)-1
 2976     Fail("Register not claimed") %if Activity(Register) < 0
 2977     Monitor Register(Register, "Released") %if Diag&MonReg # 0
 2978     Active Registers = Active Registers-1
 2979     Fail("Register unclaimed") %if Active Registers < 0
 2980  %end
 2981  
 2982  %routine To Store(%integer Code)
 2983     %if Code # 0 %start
 2984        %if Code = 3 %start     {short}
 2985           Loadup(Stack) %if Stack_Type = Bytes
 2986        %else %if Code = 1      {integer}
 2987           Loadup(Stack) %if Stack_Type = Bytes %or Stack_Type = Shorts
 2988        %finish
 2989     %finish
 2990     %if Stack_Form = Address %or Stack_Oper # 0 %or Stack_Index ## Nil %start
 2991        %if Stack_Type = Strings %or Stack_Type = Records %start
 2992           Evaluate String Expression(Stack)       {is this ok for records?}
 2993        %else
 2994           Loadup(Stack)
 2995           Hazard(Stack_Base)
 2996        %finish
 2997     %finish
 2998  %end
 2999  
 3000  %routine Pessimise(%record(Stackfm)%name V)
 3001     {this routine forces V into store - either by de-optimising it}
 3002     {or simply by storing it}
 3003     %integer Reg, N, Disp
 3004     %record(Knowfm)%name K
 3005     %record(Stackfm)%name T
 3006     Monitor(V, "Pessimise->") %if Diag&MonOperand # 0
 3007     Fail("Not loaded") %unless Inreg(V)
 3008     Reg = V_Base
 3009     N = Ktimes(Reg)
 3010     K == Knowing;  K == NIL %if N = 0
 3011     %cycle
 3012        %if K == NIL %start                                  {not known in store}
 3013           Fail("corrupt knowing") %if N # 0
 3014           Reg = V_Base                                      {Must store it}
 3015           %if R0 <= Reg <= R15 %start                       {integer}
 3016              T == Claim Work Area(Word Length, Integers)
 3017           %else                                             {floating}
 3018              T == Claim Work Area(2*Word Length, Lreals)
 3019           %finish
 3020           Disp = T_Disp     {in case SIMPLE corrupts it}
 3021           Simple(V, T)
 3022           Release(Reg)
 3023           V_Base = Local;  V_Disp = Disp;  V_Form = Direct
 3024           Drop(T)
 3025           %exit
 3026        %finish
 3027        %if K_Reg = Reg %start
 3028           N = N-1
 3029           %if K_Oper = 0 = K_Opnd %start
 3030              %if K_Ftype = V_Type<<4 + Direct %and K_Area = V_Area %c
 3031+                                              %and Locked(K_Base) %start
 3032                 Release(Reg)
 3033                 V_Base = K_Base
 3034                 V_Disp = K_Disp
 3035                 V_Extra = K_Extra
 3036                 V_Form = Direct
 3037                 V_Flags = Known Ass
 3038                 Claim(V_Base)
 3039                 %exit
 3040              %else %if K_Ftype = Integers<<4 + Address %and K_Base = 0 %c
 3041+                                                       %and K_Area = 0  {constant}
 3042                 Release(Reg)
 3043                 V_Base = 0;  V_Disp = K_Disp
 3044                 V_Form = Address
 3045                 V_Area = 0
 3046                 V_Flags = Known Ass
 3047                 %exit
 3048              %finish
 3049           %finish
 3050        %else %if K_Base = Reg
 3051           N = N-1
 3052        %finish
 3053        K == K_Link
 3054     %repeat
 3055     Monitor(V, "Pessimise<-") %if Diag&MonOperand # 0
 3056  %end
 3057  
 3058  %routine Hazard(%integer Reg)
 3059     %integer Register = |Reg|
 3060     {This unpleasant routine has to deal with the horrors of needing}
 3061     {a register and so needing to ensure that it does not hold}
 3062     {useful data already.}
 3063     {***perhaps improve use of PESSIMISE***}
 3064     %record(Stackfm)%name U, R
 3065     %integername N
 3066     %integer Disp, Stored = 0
 3067  
 3068     %routine Store
 3069        %record(Stackfm)%name T
 3070        %return %if Stored # 0
 3071        Stored = 1
 3072        %if R0 <= Register <= R15 %start                  {integer}
 3073           T == Claim Work Area(Word Length, Integers)
 3074        %else                                             {floating}
 3075           T == Claim Work Area(2*Word Length, Lreals)
 3076        %finish
 3077        Disp = T_Disp
 3078        Simple(RegV(Register), T);  Release and Drop(T)
 3079     %end
 3080  
 3081     Monitor Register(Register, "Hazard") %if Diag&MonReg # 0
 3082  
 3083     N == Activity(Register);  %return %if N <= 0      {locked/free}
 3084     U == Using
 3085     %while U ## Nil %cycle
 3086        %if U_Base = Register %start             {the index looks after itself}
 3087           Monitor(U, "Hazarding") %if Diag&MonReg # 0
 3088           %if N = 1 %and Stored = 0 %and InReg(U) %start
 3089              Pessimise(U)
 3090              %return
 3091           %finish
 3092           Store
 3093           %if U_Form = Address %and U_Disp = 0 %and U_Index == Nil %start   {it's a regster}
 3094              U_Form = Direct;  U_Base = Local;  U_Disp = Disp
 3095           %else                                         {make it look like a record}
 3096              Fail("Corrupt record") %if U_Record ## Nil
 3097              R == Local Integer(Disp)
 3098              R_Flags = Hazarded
 3099              U_Base = None;  U_Record == R
 3100           %finish
 3101           Release(Register)
 3102        %finish
 3103        U == U_Using
 3104     %repeat
 3105  
 3106     %if N # 0 %start
 3107        Fail("Use lost") %if N # 0
 3108     %finish
 3109  %end
 3110  
 3111  %routine Hazard All
 3112     Hazard(R0);  Hazard(R1);  Hazard(R2);  Hazard(R3)
 3113     %return %if Active Registers = 0
 3114     Hazard(R4);  Hazard(R5);  Hazard(R6);  Hazard(R7)
 3115     %return %if Active Registers = 0
 3116     Hazard(R8);  Hazard(R11);  Hazard(R14)
 3117     %return %if Active Registers = 0
 3118     Hazard(F0);  Hazard(F1);  Hazard(F2);  Hazard(F3)
 3119     %return %if Active Registers = 0
 3120     Hazard(F4);  Hazard(F5);  Hazard(F6);  Hazard(F7)
 3121  %end
 3122  
 3123  {Descriptor Control}
 3124  
 3125  %record(Stackfm)%map Descriptor
 3126     %record(Stackfm)%name V
 3127     %if Dasl == Nil %start                   {empty, grab some from the heap}
 3128        Dasl == NEW(Stackfm Type)
 3129        Dasl_Using == Nil
 3130     %finish
 3131     V == Dasl;  Dasl == V_Using
 3132     V = 0
 3133     V_Using == Using;  Using == V
 3134     %result == V
 3135  %end
 3136  
 3137  %routine Drop All(%record(Stackfm)%name V)
 3138     Drop All(V_Index)  %and V_Index  == Nil %if V_Index  ## Nil
 3139     Drop All(V_Record) %and V_Record == Nil %if V_Record ## Nil
 3140     Drop(V)
 3141  %end
 3142  
 3143  %routine Drop(%record(Stackfm)%name V)
 3144     %record(Stackfm)%name P, E
 3145     Monitor(V, "Drop") %if Diag&MonStack # 0
 3146     Zap Index and Record(V)
 3147     %if Using == V %start                  {first is quick}
 3148        Using == V_Using
 3149     %else                                  {otherwise search for it}
 3150        P == Using
 3151        %cycle
 3152           Fail("Not in use") %if P == Nil
 3153           E == P
 3154           P == P_Using
 3155        %repeat %until P == V
 3156        E_Using == P_Using
 3157     %finish
 3158     V_Using == Dasl;  Dasl == V
 3159  %end
 3160  
 3161  %routine Release and Drop(%record(Stackfm)%name V)
 3162     Release and Drop(V_Link) %unless V_Link == Nil
 3163     Release(V_Base)
 3164     Drop(V)
 3165  %end
 3166  
 3167  %routine Zap Index and Record(%record(Stackfm)%name V)
 3168     Release and Drop(V_Index ) %and V_Index  == Nil %unless V_Index  == Nil
 3169     Release and Drop(V_Record) %and V_Record == Nil %unless V_Record == Nil
 3170  %end
 3171  
 3172  %routine Release and Drop Pair(%record(Stackfm)%name A, B)
 3173     Release and Drop(A)
 3174     Release and Drop(B)
 3175  %end
 3176  
 3177  %routine Pop Release and Drop
 3178     %record(Stackfm)%name S
 3179     S == Stack
 3180     Stack == S_Stack
 3181     Release and Drop(S)
 3182  %end
 3183  
 3184  %routine Drop Members(%record(Stackfm)%name S)
 3185     %record(Memberfm)%name M, X
 3186     M == S_Members ; S_Members == Nil
 3187     %while M ## Nil %cycle
 3188        X == M ; M == M_Link
 3189        %if X_Const # 0 %start
 3190           Drop(X_A)
 3191           Drop(X_B) %if X_B ## Nil
 3192        %else
 3193           Release and Drop(X_A)
 3194           Release and Drop(X_B) %if X_B ## Nil
 3195        %finish
 3196        Dispose(X)
 3197     %repeat
 3198  %end
 3199  
 3200  %routine Apply Indirection   {to the stack}
 3201     %record(Stackfm)%name W
 3202     W == Stack;  Stack == Descriptor
 3203     Stack_Stack == W_Stack
 3204     Stack_Type = W_Type;    Stack_Form = Direct;  Stack_Record == W
 3205     Stack_Format = W_Format
 3206     W_Type = Integers;  W_Form = Direct;  W_Format = 0
 3207  %end
 3208  
 3209  %routine Stack True or False(%integer CC)
 3210     {CC is the condition for TRUE}
 3211     %integer Other, R, Lab
 3212     %record(Stackfm)%name V
 3213     V == Literal(0);  Optimise(V, 1)     {try for zero=false}
 3214     %if InReg(V) %start                  {Yes}
 3215        CC = Negated(CC)
 3216        Other = 1
 3217     %else                                {No, try for one=true}
 3218        V_Disp = 1;  Other = 0
 3219     %finish
 3220     Load Protected(V);  R = V_Base       {in case the register is in use}
 3221     Release and Drop(V)
 3222     Fail("register active") %unless Activity(R) = 0
 3223     Lab = New Label
 3224     Jump To(Lab, CC);  V == Literal(Other);  Load(V, R);  Define Label(Lab)
 3225     Forget(R)
 3226     V_Stack == Stack;  Stack == V
 3227  %end
 3228  
 3229  %routine Stack Var(%integer Varno)
 3230     %integer Form, Flags
 3231     %record(Stackfm)%name V
 3232     V == Descriptor
 3233     V_V = Var(Varno)
 3234     V_Varno = Varno
 3235     V_Stack == Stack
 3236     Stack == V
 3237     Attributes = Attributes ! Attr Needs Gp %if Stack_Base = SB
 3238     Form = V_Form
 3239     %if V_Flags&XData Spec # 0 %start
 3240        Flags = V_Flags;  V_Flags = 0
 3241        Apply Indirection
 3242        Stack_Flags = Flags&(\XData Spec)
 3243     %finish
 3244     Apply Indirection %if Form = Indirect       {Be careful to use original}
 3245     Monitor(Stack, "Stack Var") %if Diag&MonStack # 0
 3246  %end
 3247  
 3248  %record(Stackfm)%map Local Integer(%integer Disp)
 3249     %record(Stackfm)%name V
 3250     V == Descriptor
 3251     V_Type  = Integers;  V_Form = Direct
 3252     V_Base  = Local;     V_Disp  = Disp
 3253     V_Flags = Known Ass
 3254     %result == V
 3255  %end
 3256  
 3257  %record(Stackfm)%map Literal(%integer N)
 3258     %record(Stackfm)%name V
 3259     V == Descriptor
 3260     V_Disp = N
 3261     V_Type = Integers
 3262     V_Flags = Known Ass               {ready for form being changed to direct}
 3263     %result == V
 3264  %end
 3265  
 3266  %routine Stack Integer(%integer N)
 3267     %record(Stackfm)%name V
 3268     V == Literal(N)
 3269     V_Stack == Stack
 3270     Stack == V
 3271  %end
 3272  
 3273  %integerfn Popped Value
 3274     %record(Stackfm)%name V
 3275     V == Stack
 3276     Stack == V_Stack
 3277     Drop(V)
 3278     %result = V_Disp
 3279  %end
 3280  
 3281  %record(Stackfm)%map Temporary
 3282     {Cannot use CLAIM WORK AREA as they get released at the end of EACH statement}
 3283     %record(Stackfm)%name V
 3284     Frame = Frame&Alignment Mask - Word Length
 3285     V == Local Integer(Frame)
 3286     %result == V
 3287  %end
 3288  
 3289  %record(Stackfm)%map Copy(%record(Stackfm)%name V)
 3290     %record(Stackfm)%name C
 3291     %result == Nil %if V == Nil
 3292     C == Descriptor
 3293     C_Data = V_Data;  Claim(C_Base)
 3294     C_Oper = V_Oper
 3295     C_Index  == Copy(V_Index)  %unless V_Index  == Nil
 3296     C_Record == Copy(V_Record) %unless V_Record == Nil
 3297     C_Link   == Copy(V_Link)   %unless V_Link   == Nil
 3298     %result == C
 3299  %end
 3300  
 3301  {Stack control}
 3302  
 3303  %routine Select(%integer Item)
 3304     %record(Stackfm)%name V, X
 3305     %record(Varfm)%name Field
 3306     V == Stack
 3307     Field == Var(Var(-V_Format)_Extra-Item)
 3308     Fail("Select") %if V_Form = Address
 3309     Stack_Varno = 0
 3310     {temp frig for  A(4)_Sn == S}
 3311     %if V_Form = Direct %and V_Index == Nil %start
 3312        V_Disp   = V_Disp+Field_Disp
 3313        V_Type   = Field_Type
 3314        V_Form   = Field_Form
 3315        V_Format = Field_Format
 3316        V_Flags  = Field_Flags
 3317        V_Adata == Field_Adata
 3318     %else   {Indirect}
 3319        Amap(V)                               {ready for REDUCE}
 3320        X == Descriptor
 3321        X_V = Field;  X_Base = 0
 3322        X_Record == V
 3323        Stack == X;  X_Stack == V_Stack   {re-link it}
 3324     %finish
 3325     Apply Indirection %if Stack_Form = Indirect
 3326     Monitor(Stack, "Select") %if Diag&MonStack # 0
 3327  %end
 3328  
 3329  {Label & Jump Handling}
 3330  
 3331  %routine X Call(%integer Ep, Stackit, Hazard)
 3332     %record(Stackfm)%name V
 3333     Hazard All %if Hazard > 0 %and Active Registers # 0
 3334     Dir2(Dir Xcall, Ep);  Refs = Refs+1;  Ca = Ca+4
 3335     Forget Everything %unless Hazard < 0
 3336     Attributes = Attributes!Attr Needs Gp
 3337     %if Stackit # 0 %start
 3338        Attributes = Attributes!Attr Dynamic
 3339        V == Register(Stackit)
 3340        V_Stack == Stack;  Stack == V
 3341     %finish
 3342  %end
 3343  
 3344  %routine Check Compiler Label(%integer Label)
 3345     Fail("compiler labels/1") %if Label > Max Label
 3346  %end
 3347  
 3348  %integerfn New Label
 3349     Free Label = Free Label+1
 3350     Fail("too many internal labels") %if Free Label&16_8000 # 0
 3351     %result = Free Label
 3352  %end
 3353  
 3354  %routine Jump to(%integer Internal Label, Cond Code)
 3355     Jlab = Internal Label                        {remember for Events}
 3356     Cond Code = Reverse(Cond Code) %and Invert = 0 %if Invert # 0
 3357     Dir3(Dir Branch, Internal Label, Cond Code+Unsigned);  Unsigned = 0
 3358     Refs = Refs+1
 3359     Ca = Ca+4                                    {assume 2 bytes worth}
 3360     Uncond Jump = Ca %if Cond Code = Always      {can't get past here}
 3361     Assign Lock = 0                              {no longer safe}
 3362  %end
 3363  
 3364  %routine Define Label(%integer Internal Label)
 3365     Dir2(Dir Label, Internal Label)
 3366     Uncond Jump = -1                             {can get here now}
 3367     Assign Lock = 0                              {can no-longer remember ass}
 3368  %end
 3369  
 3370  %routine Define Compiler Label(%integer Label)
 3371     %record(Labelfm)%name L
 3372     Check Compiler Label(Label)
 3373     L == Ilabel(Label)
 3374     %if L_Lab&Defined # 0 %start                     {redefinition}
 3375        Forget Environment(Label)
 3376        L_Lab = New Label
 3377     %finish
 3378     L_Lab = L_Lab!Defined                           {show it's defined}
 3379     Merge Environment(Label) %if Uncond Jump # Ca
 3380     Define Label(L_Lab&Label Mask)
 3381     Restore Environment(Label)
 3382  %end
 3383  
 3384  %integerfn Forward Label(%integer Label)
 3385     %record(Labelfm)%name L
 3386     L == Ilabel(Label)
 3387     %if L_Lab&Defined # 0 %start                     {redefine it}
 3388        L_Lab = New Label
 3389        Remember Environment(Label)
 3390     %else                               {another reference}
 3391        Merge Environment(Label)
 3392     %finish
 3393     %result = L_Lab
 3394  %end
 3395  
 3396  %routine Jump Forward(%integer Label, Cond Code)
 3397     Check Compiler Label(Label)
 3398     Jump To(Forward Label(Label), Cond Code)
 3399     %if Cond Code = NE %and Pending Known Register # 0 %start
 3400        Remember(Pending Known Register, Pending Known)
 3401     %finish
 3402     Pending Known Register = 0
 3403  %end
 3404  
 3405  %routine Jump Backward(%integer Label)
 3406     %record(Stackfm) C, F
 3407     %record(Stackfm)%name U, CC
 3408     %record(Forfm)%name For == Nil
 3409     %record(Varfm)%name Vr
 3410     %record(Labelfm)%name L
 3411     %integer How
 3412     Check Compiler Label(Label)
 3413     L == Ilabel(Label)
 3414     How = Always
 3415     Fail("Label missing") %if L_Lab&Defined = 0
 3416     %if Fors ## Nil %and Label = Fors_Label %start  {repeat of a %for stat}
 3417        For == Fors;  Fors == Fors_Link              {unchain this item}
 3418        C_Data = For_Control
 3419        Vmap(C, For_Type)
 3420        Load(C, For_Reg)
 3421        Define Compiler Label(For_Entry) %if For_Entry # 0
 3422        F_Data = For_Final
 3423        Compare(C, F);  Release(C_Base);  Release(F_Base)
 3424        How = For_CC
 3425     %finish
 3426     Jump To(L_Lab&Label Mask, How)
 3427     %if For ## Nil %start
 3428           %if How # Always %and Language Flags&Undefined Control # 0 %c
 3429+                        %and Unassigned # 0 %start
 3430           CC == Literal(0)
 3431           CC_Data = For_Control
 3432           Vmap(CC, For_Type)
 3433           U == Copy(UaPat);  U_Type = For_Type
 3434           Simple(U, CC)            {Zap the control variable}
 3435           Forget Destination(CC)   {PSR 02NOV87}
 3436           Forget(U_Base)           {beware of remembering bytes with zero}
 3437           Release and Drop(U)
 3438           Release and Drop(CC)
 3439           %if For_Control_Varno # 0 %start
 3440              Vr == Var(For_Control_Varno)
 3441              Vr_Flags = Vr_Flags&(\Known Ass)
 3442           %finish
 3443        %finish
 3444        Dispose(For)
 3445     %finish
 3446  %end
 3447  
 3448  %routine Set User Label(%integer Label)
 3449     %record(Varfm)%name V
 3450     V == Var(Label)
 3451     Clear Vars(Label)
 3452     V_Type = Labels
 3453     V_Base = Local
 3454     V_Disp = New Label
 3455  %end
 3456  
 3457  %routine User Jump(%integer Label)
 3458     %owninteger Jout = 0
 3459     %integer B
 3460     %record(Stackfm)%name Base
 3461     %record(Varfm)%name V
 3462     %record(Varfm) C
 3463     V == Var(Label)
 3464     Set User Label(Label) %if Label > Vars %or V_Disp = 0       {Not in Yet allocated a var}
 3465     B = V_Base
 3466     %if B # Local %start                                        {non-local}
 3467        Base == Display Info(B)
 3468        Release and Drop(Base)
 3469        Base == Literal(0);  Base_Base = B;  Base_Flags = Known Ass
 3470        Load(Base, Fp)                              {Restore old Fp}
 3471        Base_Disp = V_Extra;  Base_Form = Direct;  Base_Flags = Known Ass
 3472        Load(Base, R3);  Release and Drop(Base)     {new value for SP}
 3473        Do("3L_pascal___jump_out", Jout, 0)
 3474     %finish
 3475     Jump To(V_Disp, Always)
 3476  %end
?C unused
 3477  
 3478  %routine Mark User Label
 3479     Dir1(Dir Mark User)
 3480  %end
 3481  
 3482  %routine Define User Label(%integer Label)
 3483     %record(Varfm)%name V
 3484     V == Var(Label)
 3485     Set User Label(Label) %if Label > Vars %or V_Disp = 0       {Not in Yet allocated a var}
 3486     Define Label(V_Disp)
 3487     Mark User Label
 3488     Forget Everything
 3489  %end
 3490  
 3491     %routine Return(%integer How)
 3492        %integer Result Reg, Type
 3493        %record(Stackfm)%name V, W
 3494        %if Uncond Jump = Ca %start
 3495           Pop Release and Drop %if How < 0                 {remove stacked result}
 3496           %return
 3497        %finish
 3498        V == Nil
 3499        Result Reg = R0
 3500        Type = Avar_Type
 3501        %if How = True %start
 3502           V == Literal(1)
 3503        %else %if How = False
 3504           V == Literal(0)
 3505        %else %if How # 0
 3506           V == Stack;  Stack == Stack_Stack
 3507           %if How = Map %start
 3508              Amap(V)
 3509              Type = Addrs              {map result types are addresses}
 3510           %else %if Type = Strings %or Type = Records
 3511              W == Literal(0)
 3512              W_Type = Type;  W_Form = Direct
 3513              W_Record == Local Integer(String Result)
 3514              W_Record_Format = Avar_Format
 3515              %if W_Type = Strings %then String Assign(V, W) %c
 3516+                                  %else Record Assign(V, W)
 3517              Release and Drop Pair(W, V)
 3518              V == Nil
 3519           %finish
 3520        %finish
 3521        %if V ## Nil %start
 3522           %if Type = Reals %or Type = Lreals %start
 3523              Load(V, F0)
 3524           %else
 3525              Load(V, Result Reg)
 3526           %finish
 3527           Release and Drop(V)
 3528        %finish
 3529        Dir2(Dir Return, Parameter Frame)
 3530        Refs = Refs+1
 3531        Ca = Ca+4                                    {assume two bytes}
 3532        Uncond Jump = Ca                             {Can't get past here}
 3533        Open = 0                                     {the procedure returns}
 3534     %end
 3535  
 3536     %routine Stab(%record(Stackfm)%name V)
 3537        %record(Stackfm)%name T, TT
 3538        %return %if Iconst(V)
 3539        T == Temporary;  TT == Copy(T)               {in case of corruption by store}
 3540        Store(V, T)
 3541        Release and Drop(T)
 3542        Replace(V, TT)
 3543        V_Flags = V_Flags!Known Ass
 3544     %end
 3545  
 3546     %routine Compile For(%integer Repeat Label)
 3547        %integer Type, N
 3548        %record(Stackfm)%name Initial,         {initial value}
 3549+                             Final,           {final value}
 3550+                             Inc,             {increment}
 3551+                             Control,         {control variable}
 3552+                             Increment,       {copy of increment}
 3553+                             C                {copy of control}
 3554  
 3555        %record(Forfm)%name For
 3556        %record(Varfm)%name V
 3557  
 3558        %integerfn Loop Type
 3559           %integer I, N
 3560           %result = 1 %unless Iconst(Initial) %and Iconst(Inc)  %c
 3561+                                              %and Iconst(Final)
 3562           I = Inc_Disp
 3563           N = Final_Disp-Initial_Disp+I
 3564           %if I # 0 %start
 3565              %result = 1 %if N = 0                   {zero iterations?}
 3566              %if N!!I >= 0 %and Rem(N, I) = 0 %start {constant}
 3567                 %if For Range ## Nil %start
 3568                    %unless For Range_Disp <= Initial_Disp <= For Range_Extra %and
 3569+                           For Range_Disp <=   Final_Disp <= For Range_Extra %start
 3570                       %result = 1                    {check it dynamically}
 3571                    %finish
 3572                    For Range == Nil                 {all OK}
 3573                 %finish
 3574                 %result = 0
 3575              %finish
 3576           %finish %else I = 1
 3577           %if Language Flags&Non Exact For = 0 %start
 3578              Warn(1, "Non-integral %for loop")
 3579              Final_Disp = Initial_Disp+N//I*I
 3580           %finish
 3581           %result = 1
 3582        %end
 3583  
 3584        Final          ==         Stack
 3585        Inc            ==   Final_Stack
 3586        Initial        ==     Inc_Stack
 3587        Control        == Initial_Stack
 3588        Stack          == Control_Stack
 3589  
 3590        Stab(Inc)
 3591        Type = Control_Type
 3592        %unless Control_Form = Direct  %c
 3593+          %and Control_Index == NIL   %c
 3594+          %and Control_Record == NIL  %c
 3595+          %and  (Control_Base = None  %c
 3596+             %or Control_Base = Local %c
 3597+             %or Control_Base = SB)   %start
 3598           {protect expensive (i.e. non-local) or moveable control variable}
 3599           Amap(Control);  Stab(Control)      {save its address}
 3600        %else
 3601           Amap(Control)
 3602        %finish
 3603        Simplify(Control)
 3604  
 3605        For == NEW(ForfmType);  For_Link == Fors;  Fors == For
 3606        For_Label   = Repeat Label
 3607        For_Control = Control_Data
 3608        Vmap(Control, Type);  For_Type = Type
 3609        For_Entry   = Loop Type               {and check on the fly}
 3610        For_AS      = 0                       {no +1 or -1 yet}
 3611  
 3612        N = Inc_Disp
 3613        For_CC = NE
 3614        %if Language Flags&Non Exact FOR # 0 %and For_Entry # 0 %start
 3615           %if N = 1 %start
 3616              For_CC = LT
 3617           %else %if N = -1
 3618              For_CC = GT
 3619           %finish %else Fail("corrupt increment")
 3620        %finish
 3621        Increment == Copy(Inc)        {beware of corruption in operate}
 3622        Operate(SUBx, Initial, Inc)
 3623        Loadup(Initial);  For_Reg   = Initial_Base
 3624        Stab(Final);          For_Final = Final_Data
 3625        Load(Initial, For_Reg)                    {beware of HAZARD in STAB}
 3626        %if For_Entry # 0 %start                  {may never execute the loop}
 3627           %if Language Flags&Undefined Control = 0 %start
 3628              {must save the initial value in case the loop isn't executed}
 3629              C == Copy(Control)
 3630              Store(Initial, C)
 3631              Release and Drop(C)
 3632           %finish
 3633           For_Entry = Repeat Label+2
 3634           Jump Forward(For_Entry, Always)
 3635        %finish
 3636        Define Compiler Label(Repeat Label)
 3637  
 3638        %if For_AS = 0 %start
 3639           Operate(ADDX, Initial, Increment)
 3640           Load(Initial, For_Reg)                {can be removed if desired!}
 3641        %finish
 3642        %if For Range ## Nil %start
 3643           Test Range(Initial, For Range)                {check initial value}
 3644           For Range == Nil
 3645        %finish
 3646        Store(Initial, Control)
 3647        For_Control_V_Flags = For_Control_V_Flags!Known Ass
 3648  
 3649        %if Control_Varno # 0 %start
 3650           V == Var(Control_Varno)
 3651           V_Flags = V_Flags!Known Ass
 3652        %finish
 3653        Release and Drop Pair(Control, Initial)
 3654        Release and Drop(Final)
 3655     %end
 3656  
 3657     %record(Stackfm)%map Const String
 3658        %record(Stackfm)%name W
 3659        Constant Base = (Constant Base+3)&(\3)   {align it}
 3660        Select Constant Area
 3661        W == Literal(Ca)
 3662        W_Type = Strings;  W_Form = Direct
 3663        W_Area = Constant Area
 3664        W_Format = Length(Value_String)+1
 3665        W_Bias   = W_Format
 3666        Dump Text(0) %unless Value_String = ""   {I think this is safe?}
 3667        Select Code Area
 3668        %result == W
 3669     %end
 3670  
 3671     %routine Fix Tostring(%record(Stackfm)%name C)
 3672        %record(Stackfm)%name W
 3673        Value_String = Tostring(C_Disp)
 3674        W == Const String
 3675        C_Data = W_Data
 3676        Drop(W)
 3677     %end
 3678  
 3679     %routine Set Size or Type(%integer ST, %record(Stackfm)%name V)
 3680        %integer N
 3681        %if V_Type = Generals %start
 3682           Amap(V)
 3683           V_Disp = V_Disp+ST*Word Length              {<addr><size><type>}
 3684        %else
 3685           %if ST = 1 {sizeof} %start
 3686              N = Item Size(V_Format)
 3687              %if N = 1 %and V_Type = Strings %start   {string(*)name}
 3688                 Amap(V)
 3689                 Advance(V, Integers, Wordlength)
 3690                 %return
 3691              %finish
 3692           %else
 3693              N = Type Code(V_Type)
 3694           %finish
 3695           Release(V_Base)
 3696           Zap Index and Record(V)
 3697           V_Data = 0
 3698           V_Disp = N
 3699           V_Type = Integers
 3700           V_Form = Address
 3701        %finish
 3702     %end
 3703  
 3704     %include "call.inc"
 &1     !Revision history
 &2     
 &3     !  8-Jul-87 PSR INT was using the wrong instruction format to add the 0.5
 &4     !             - Readsymbol etc weren't hazarding registers
 &5     
 &6     %routine Apply Trunc(%record(Stackfm)%name V)
 &7        %integer R
 &8        %return %unless Floating(V)
 &9        Load(V, AnyF); Release(V_Base)
 &10       R = GPR
 &11       Plant7(FIX ! 2_11<<5, 0, R, V_Base)   {round to zero}
 &12       V_Type = Integers;  V_Base = R;  Claim(R)
 &13    %end
 &14    
 &15    %routine Convert Function(%integer Op, %record(Stackfm)%name V)
 &16       %return %unless Floating(V)
 &17       Load(V, F0);  Release(F0)
 &18       Prim(Op)
 &19       V_Type = Integers;  V_Base = R0;  Claim(R0)
 &20    %end
 &21    
 &22    %routine Apply Round(%record(Stackfm)%name V)
 &23       Convert Function(Real Round, V)
 &24    %end
 &25    
 &26    %routine Apply Intpt(%record(Stackfm)%name V)
 &27       %integer R
 &28       %return %unless Floating(V)
 &29       Load(V, AnyF); Release(V_Base)
 &30       R = GPR
 &31       Plant7(FIX ! 2_10<<5, 0, R, V_Base)   {round to minus infinity}
 &32       V_Type = Integers;  V_Base = R;  Claim(R)
 &33    %end
 &34    
 &35    %routine Apply Int(%record(Stackfm)%name V)
 &36       %integer R
 &37       %return %unless Floating(V)
 &38       Load(V, AnyF); Release(V_Base)
 &39       Plant9(ADF ! Small Constant, V_Base, V_Base, 6)   {add 0.5}
 &40       R = GPR
 &41       Plant7(FIX ! 2_10<<5, 0, R, V_Base)   {round to minus infinity}
 &42       V_Type = Integers;  V_Base = R;  Claim(R)
 &43    %end
 &44    
 &45    %routine X Define(%integername Ep, %string(63) Text, %integer P)
 &46       %record(Varfm) C = 0
 &47       %if Ep = 0 %start
 &48          External Id = Text
 &49          %if P = 0 %start               {data}
 &50             Dump External(2_00, C)
 &51             Ep = C_Area
 &52          %else
 &53             C_Form = Proc
 &54             Dump External(2_10, C)
 &55             Ep = C_Disp
 &56          %finish
 &57       %finish
 &58    %end
 &59    
 &60    %routine Stack Register(%integer R)
 &61       %record(Stackfm)%name X == Literal(0)
 &62       X_Base = R;  Claim(R)
 &63       X_Stack == Stack;  Stack == X
 &64    %end
 &65    
 &66    %routine Do(%string(31) Ident, %integername Ep, %integer Result)
 &67       X Define(Ep, Ident, 1)
 &68       X Call(Ep, Result, 1)
 &69    %end
 &70    
 &71    %routine Do Conditional External(%integer CC, %string(31) Ident,
 &72  +                                  %integername Ep)
 &73       %integer Label
 &74       X Define(Ep, Ident, 1)
 &75       Hazard All %if Active Registers # 0
 &76       %if CC # Always %start
 &77          Label = New Label
 &78          Jump To(Label, Negated(CC))
 &79       %finish
 &80       X Call(Ep, 0, 0)
 &81       Define Label(Label) %if CC # Always
 &82    %end
 &83    
 &84    %routine Special Call(%integer N)
 &85       %record(Stackfm)%name V == Stack, X, Y, Z
 &86       %owninteger Readch Ep = 0, Iread = 0, Rread = 0, Sread = 0, Nextch Ep = 0
 &87       %integer Type
 &88       %constinteger Max Special = 59
 &89       %switch Sp(1:Max Special)
 &90       %constbytearray Type Map(3:9) = Strings, Integers, Shorts, Bytes, Reals,
 &91  +                                     Lreals,  Records
 &92       %constbytearray Len Map(3:9) =        0,        4,      2,     1,     4,
 &93  +                                          8,        0
 &94    
 &95    
 &96             ->Sp(N) %if 0 < N <= Max Special
 &97    Sp(*):   Fail("Bad primitive")
 &98    
 &99       %routine Psym(%record(Stackfm)%name Char)
 &100         %owninteger Printsymbol Ep = 0
 &101         Load(Char, R0);  Release and Drop(Char)
 &102         Prim(Psymbol)
 &103         Forget Everything
 &104      %end
?PRINTSYMBOLEP unused
 &105   
 &106      %routine Do Printstring
 &107         %owninteger Printstring Ep = 0
 &108         %record(Stackfm)%name S, V == Stack
 &109         Stack == Stack_Stack                {pop the string}
 &110         %cycle
 &111            S == V;  V == S_Link;  S_Oper = 0;  S_Link == Nil
 &112            %if S_Type <= Addrs %start
 &113               Psym(S)
 &114            %else %if S_Bias = 1                {null}
 &115               Release and Drop(S)
 &116            %else
 &117               Amap(S);  Load(S, R0)
 &118               Release and Drop(S)
 &119               Do("3L_IMP_PRINT_STRING", Printstring Ep, 0)
 &120            %finish
 &121         %repeat %until V == Nil
 &122      %end
 &123   
 &124      %routine Load External Variable(%string(63) Id, %integername Ep)
 &125         %record(Stackfm)%name V
 &126         %record(Varfm) X
 &127         %if Ep = 0 %start
 &128            X_Form = 0
 &129            External Id = Id;  Dump External(0, X)
 &130            Ep = -X_Area
 &131         %finish
 &132         Hazard(R1)
 &133         Dir3(Dir Spec Load, Actual(R1), Ep)
 &134         Refs = Refs+1;  Ca = Ca+4
 &135         Attributes = Attributes ! Attr Needs Gp
 &136      %end
?V unused
 &137   
 &138      %routine Do Input(%integer Fn)
 &139         %record(Stackfm)%name R
 &140         %owninteger In Scb = 0
 &141         Hazard All
 &142         Load External Variable("3L___cur_in", In Scb) {LDR _ 1, IN___SCB}
 &143         Forget Everything
 &144         Dump Word(16_E4911000)                         {LDR _ R1, [R1]}
 &145         Dump Word(16_E891001C)                         {LDM _ R1, <r2,r3,r4>}
 &146            {R2 = Next}
 &147            {R3 = Limit}
 &148            {R4 = Buffer Handler}
 &149         Dump Word(16_E1520003)                         {CMP _ R2, R3        }
 &150         Prim(Enter P)                                  {BLGE_ (R4)          }
 &151         %if Fn = 0 %start                              {nextsymbol          }
 &152            {don't advance}
 &153            Dump Word(16_E4D24000)                      {LDRB_ R4, [R2]      }
 &154         %else
 &155            {advance}
 &156            Dump Word(16_E4D24001)                      {LDRB _ R4, [R2], #1! }
 &157            Dump Word(16_E4012000)                      {STR _ R2, [R1]      }
 &158         %finish
 &159         %if Fn >= 0 %start                             {readsymbol/nextsymbol}
 &160            {give some result}
 &161            R == Register(R4)
 &162            R_Stack == Stack;  Stack == R
 &163            Assign(Equals) %if Fn = 1               {readsymbol}
 &164         %finish
 &165      %end
 &166   
 &167   Sp(1):   Do Input( 1);  %return    {readsymbol}
 &168   Sp(2):   Do Input( 0);  %return    {nextsymbol}
 &169   Sp(26):  Do Input(-1);  %return    {skipsymbol}
 &170   
 &171   Sp(25):  Stack == V_Stack;  Psym(V);  %return     {Printsymbol}
 &172   Sp(27):  X == Literal(10);  Psym(X);  %return     {Newline}
 &173   Sp(28):  X == Literal(32);  Psym(X);  %return     {Space}
 &174   Sp(24):  Do Printstring;  %return                 {Printstring}
 &175   
 &176   Sp(23):  %if V_Type = Strings %start              {Read(STRING)}
 &177               Type = Strings
 &178               X == Literal(Item Size(Stack_Format)-1)
 &179               Amap(Stack);  Load(Stack, R0)
 &180                             Load(X, R1);  Release and Drop(X)
 &181               Pop Release and Drop
 &182               Do("3L_IMP___read_s", Sread, 0)
 &183            %else
 &184               %if Integers <= V_Type <= Addrs %start
 &185                  Type = Integers;  Do("3L_IMP___read_i", Iread, R0)
 &186               %else %if V_Type = Reals %or V_Type = Lreals
 &187                  Type = Lreals;  Do("3L_IMP___read_r", Rread, F0)
 &188               %else
 &189                  Warn(1, "Bad type of parameter for READ")
 &190                  Type = Integers
 &191               %finish
 &192               Stack_Type = Type
 &193               Stack_Form = Direct %if Type = Strings
 &194               Assign(Equals)
 &195            %finish
 &196            %return
 &197   Sp(20):  Amap(V);  %return                        {addr}
 &198   
 &199   Sp(3):                                            {string}
 &200   Sp(4):                                            {integer}
 &201   Sp(5):                                            {shortinteger, short}
 &202   Sp(6):                                            {byteinteger, byte}
 &203   Sp(7):                                            {real}
 &204   Sp(8):                                            {longreal, long}
 &205   Sp(9):   Vmap(V, Type Map(N))                     {record}
 &206            V_Format = Len Map(N)
 &207            %return
 &208   Sp(10):  Float(Stack, FPR);  %return              {float}
 &209   Sp(11):  X == V_Stack;  Stack == X_Stack          {rem}
 &210            Operate(REMx, V, X)
 &211            V_Stack == Stack;  Stack == V
 &212            %return
 &213   Sp(12):  Advance(V, Bytes, 0)                     {length}
 &214            %return
 &215   Sp(13):  X == V_Stack;  Stack == X_Stack          {charno - the index}
 &216            Simplify(V) %if V_Index ## Nil
 &217            V_Type = Bytes
 &218            Apply Index(V, X, 1)
 &219            V_Stack == Stack;  Stack == V            {stack the result}
 &220            %return
 &221   Sp(14):  Stack Integer(Nl)                        {snl}
 &222   Sp(15):  Simplify(Stack)                          {tostring}
 &223            %return
 &224   Sp(16):  Set Size or Type(1, V);  %return         {sizeof}
 &225   Sp(17):  Set Size or Type(2, V);  %return         {typeof}
 &226   Sp(19):  Apply   Int(V);  %return                 {int}
 &227   Sp(18):  Apply Intpt(V);  %return                 {intpt}
 &228   Sp(22):  Apply Round(V);  %return                 {round}
 &229   Sp(21):  Apply Trunc(V);  %return                 {trunc}
 &230   
 &231   {=== Pascal items ===}
 &232   
 &233   %conststring({*}255)   Fill Id = "3L_pascal___fill";        %owninteger   Fill Ep = 0
 &234   %conststring({*}255)   Ftxt Id = "3L_pascal___fill_text";   %owninteger   Ftxt Ep = 0
 &235   %conststring({*}255)   Safe Id = "3L_pascal___safe";        %owninteger   Safe Ep = 0
 &236   %conststring({*}255)  Empty Id = "3L_pascal___empty";       %owninteger  Empty Ep = 0
 &237   %conststring({*}255)   Eoln Id = "3L_pascal___eoln_error";  %owninteger   Eoln Ep = 0
 &238   %conststring({*}255) Readln Id = "3L_pascal___read_ln";     %owninteger Readln Ep = 0
 &239   %conststring({*}255) WritelnId = "3L_pascal___write_ln";    %owninteger WritelnEp = 0
 &240   %conststring({*}255) WriteC Id = "3L_pascal___write_char";  %owninteger WriteC Ep = 0
 &241   
 &242   %constinteger InLim Displacement =  0,
 &243 +              Outlim Displacement =  4,
 &244 +                Size Displacement =  8,
 &245 +                 EOF Displacement = 12,
 &246 +                EOLN Displacement = 13
 &247   
 &248            %routine Make Safe(%record(Stackfm)%name F, %integer EOF)
 &249               %record(Stackfm)%name P, B, V2, V3
 &250               Simplify(F)
 &251               Advance(F, Integers, 0)
 &252               P == Copy(F)                            {Buffer Pointer}
 &253               B == Copy(F);  Advance(B, Integers, 4)  {PFCB}
 &254               %if B_Base >= 128 %or Activity(B_Base) < 0 %start  {can remember}
 &255                  V2 == Copy(B)
 &256                  V3 == Copy(P)
 &257               %else
 &258                  V2 == NIL
 &259                  V3 == NIL
 &260               %finish
 &261               Load(B, R2)
 &262               P_Flags = P_Flags ! Known Ass;  Load(P, R3)
 &263               Vmap(B, Integers)
 &264               Advance(B, Integers, InLim Displacement);  B_Flags = B_Flags ! Known Ass
 &265               Load(B, R4)
 &266               Compare(P, B);  Release and Drop Pair(P, B)
 &267               {EOF # 0 implies that EOF is an error}
 &268               %if EOF = 0 %then Do Conditional External(GT, Ftxt Id, Ftxt Ep) {-}%c
 &269 +                         %else Do Conditional External(GT, SAFE Id, SAFE Ep)
 &270               F_Flags = F_Flags ! Known Ass
 &271               %if V2 ## NIL %start          {remember things}
 &272                  Remember(R2, V2)
 &273                  Remember(R3, V3)
 &274                  Release and Drop Pair(V2, V3)
 &275                  V2 == Register(R2);  V2_Form = Direct
 &276                  Remember(R4, V2);  Release and Drop(V2)
 &277               %finish
 &278            %end
 &279   
 &280            %routine Onto Boolean(%record(Stackfm)%name F, %integer Disp, Known)
 &281               Advance(F, Integers, 4)     {onto PFCB}
 &282               F_Flags = F_Flags ! Known
 &283               Load(F, R2)
 &284               Vmap(F, Bytes);  Advance(F, Bytes, Disp)
 &285               F_Flags = F_Flags ! Known Ass
 &286            %end
 &287   
 &288            %routine EOF(%record(Stackfm)%name F, %integer Text)
 &289               Make Safe(F, 0) %if Text # 0
 &290               Onto Boolean(F, EOF Displacement, 0)
 &291            %end
 &292   
 &293            %routine EOLN(%record(Stackfm)%name F)
 &294               {EOLN must first test EOF as EOLN is invalid if EOF is true}
 &295               Make Safe(F, 1)
 &296               Onto Boolean(F, EOLN Displacement, Known Ass)
 &297            %end
 &298   
 &299            !%prim(41)%routine    P Get %alias"P_p_get"(%integername F)
 &300   Sp(41):  Stack == Stack_Stack
 &301            Simplify(V)
 &302            Advance(V, Integers, 0)
 &303            X == Copy(V)
 &304            Y == Copy(V);             Load(Y, R3)     {Buffer Pointer}
 &305            Advance(V, Integers, 4);  V_Flags = V_Flags ! Known Ass
 &306            Load(V, R2)     {PFCB}
 &307            V_Form = Direct
 &308            Z == Copy(V)
 &309            Advance(V, Integers, Size Displacement);  V_Flags = V_Flags ! Known Ass
 &310            Operate(ADDx, Y, V)
 &311            Advance(Z, Integers, InLim Displacement);  Z_Flags = Z_Flags ! Known Ass
 &312            Compare(Y, Z);  Release and Drop Pair(Z, Y)
 &313            Do Conditional External(GT, Fill Id, FILL Ep)
 &314            Y == Register(R3);  Simple(Y, X)
 &315            Release and Drop Pair(X, Y)
 &316            %return
 &317   
 &318            !%prim(42)%routine    P Get Txt %alias"P_p_getx"(%integername F)
 &319   Sp(42):  Stack == Stack_Stack
 &320            Make Safe(V, 1)
 &321            Advance(V, Integers, 0)      {Onto Buffer Pointer}
 &322            Y == Register(R3)            {loaded by MAKE SAFE}
 &323            Operate(ADDx, Y, Literal(1))
 &324            Simple(Y, V)
 &325            Release and Drop Pair(V, Y)
 &326            %return
 &327   
 &328            !%prim(43)%integerfn  P Safety %alias"P_p_safe"(%integername F)
 &329   Sp(43):  Stack == Stack_Stack
 &330            Make Safe(V, 1)
 &331            Release and Drop(V)
 &332            V == Register(R3)
 &333            V_Stack == Stack;  Stack == V
 &334            %return
 &335   
 &336            !%prim(44)%integerfn  P ReadC %alias"P_p_rc"(%integername F)
 &337   Sp(44):  Stack == Stack_Stack
 &338            Make Safe(V, 1)
 &339            Y == Register(R3)
 &340            X == Register(R1)
 &341            Plant1(LDR ! Byte Op ! 16_0080 0000, R3, R1, 1)
 &342            Simple(Y, V)
 &343            Release and Drop Pair(V, Y)
 &344            X_Stack == Stack;  Stack == X
 &345            %return
 &346   
 &347            !%prim(45)%routine   P Readln %alias"P_p_rln"(%integername F)
 &348   Sp(45):  Stack == Stack_Stack
 &349            Advance(V, Integers, 4)       {onto PFCB}
 &350            Load(V, R2)
 &351            Release and Drop(V)
 &352            Do(READLN Id, READLN Ep, 0)
 &353            %return
 &354   
 &355            !%prim(46)%integerfn  P Eoln %alias"P_p_eoln"(%integername F)
 &356   Sp(46):  EOLN(V)
 &357            %return
 &358   
 &359            !%prim(47)%integerfn  P Eof %alias"P_p_eof"(%integername F)
 &360   Sp(47):  EOF(V, 0);  %return
 &361   
 &362            !%prim(48)%integerfn  P Eof Txt %alias "P_p_eofx"(%integername F)
 &363   Sp(48):  EOF(V, 1);  %return
 &364   
 &365            !%prim(49)%routine    P Put %alias"P_p_put"(%integername F)
 &366   Sp(49):  Stack == Stack_Stack
 &367            Simplify(V)
 &368            Advance(V, Integers, 0)
 &369            X == Copy(V)
 &370            Y == Copy(V);  Advance(Y, Integers, 4);  Y_Flags = Y_Flags ! Known Ass
 &371            Load(X, R3)
 &372            Load(Y, R2)
 &373            Y_Form = Direct;  Y_Disp = OutLim Displacement
 &374            Y_Flags = Y_Flags ! Known Ass
 &375            Z == Copy(Y);  Z_Disp = Size Displacement
 &376            Operate(ADDx, X, Z);  Load(X, R3)
 &377            Compare(X, Y);  Release and Drop Pair(Y, X)
 &378            Do Conditional External(GE, EMPTY Id, EMPTY Ep)
 &379            X == Register(R3)
 &380            Simple(X, V)
 &381            Release and Drop Pair(X, V)
 &382            %return
 &383   
 &384            !%prim(50)%routine    P Put Txt %alias"P_p_put"(%integername F)
 &385   Sp(50):  Stack == Stack_Stack
 &386            Simplify(V)
 &387            Advance(V, Integers, 0)
 &388            X == Copy(V)
 &389            Y == Copy(V);  Advance(Y, Integers, 4);  Y_Flags = Y_Flags ! Known Ass
 &390            Load(X, R3)
 &391            Load(Y, R2)
 &392            Operate(ADDx, X, Literal(1));  Load(X, R3)
 &393            Y_Form = Direct;  Y_Disp = OutLim Displacement
 &394            Y_Flags = Y_Flags ! Known Ass
 &395            Compare(X, Y);  Release and Drop Pair(Y, X)
 &396            Do Conditional External(GE, EMPTY Id, EMPTY Ep)
 &397            X == Register(R3)
 &398            Simple(X, V)
 &399            Release and Drop Pair(X, V)
 &400            %return
 &401   
 &402            !%prim(51)%routine    W Line %alias"P_p_line"(%integername F)
 &403   Sp(51):  Stack == Stack_Stack
 &404            Advance(V, Integers, 4)
 &405            Load(V, R2);  Release and Drop(V)
 &406            Do Conditional External(Always, Writeln Id, Writeln Ep)
 &407            %return
 &408   
 &409            !%prim(52)%routine    W Char %alias"P_p_wchr"(%integername F, %integer C, W)
 &410   Sp(52):  %begin
 &411               %record(Stackfm)%name C, W, Bp, FCB, Z
 &412               Simplify(V)
 &413               C == V_Stack
 &414               W == C_Stack
 &415               Stack == W_Stack
 &416               %if Iconst(W) %and W_Disp = 1 %start
 &417                  Release and Drop(W)
 &418                  Advance(V, Integers, 0)
 &419                  Bp == Copy(V)
 &420                  FCB == Copy(V);  Advance(FCB, Integers, 4)
 &421                  Load(Bp, R3)
 &422                  FCB_Flags = FCB_Flags ! Known Ass
 &423                  Load(FCB, R2)
 &424                  Loadup(C);  Plant1(STR ! Byte Op ! 16_0080 0000, R3, C_Base, 1)
 &425                  Release and Drop(C)
 &426                  FCB_Form = Direct;  FCB_Disp = OutLim Displacement
 &427                  FCB_Flags = FCB_Flags ! Known Ass
 &428                  Compare(Bp, FCB);  Release and Drop Pair(FCB, Bp)
 &429                  Do Conditional External(GT, EMPTY Id, EMPTY Ep)
 &430                  Bp == Register(R3)
 &431                  Simple(Bp, V)
 &432                  Release and Drop Pair(Bp, V)
 &433               %else
 &434                  Load(W, R1)
 &435                  Load(C, R2)
 &436                  Amap(V);  Load(V, R3)
 &437                  Release and Drop Pair(W, C)
 &438                  Release and Drop(V)
 &439                  Do(WRITEC Id, WRITEC Ep, 0)
 &440               %finish
 &441            %end
?Z unused
 &442            %return
 &443   
 &444            !%prim(53)%routine    Assoc Complete %alias"P_p_assc"
 &445   Sp(53):  %return                   {no need for Assoc complete on ARM - yet}
 &446   
 &447            %routine Do Real Fn(%integer Fn)
 &448               %integer Reg
 &449               Load(V, AnyF)
 &450               Reg = Fpr;  Claim(Reg)
 &451               Plant9(Fn, 0, Reg, V_Base)
 &452               Release(V_Base);  V_Base = Reg
 &453            %end
 &454   
 &455   Sp(54):  !%prim(54)%longrealfn Sqrt(%longreal R)
 &456            Do Real Fn(SQT);  %return
 &457   
 &458   Sp(55):  !%prim(55)%longrealfn Sin(%longreal R)
 &459            Do Real Fn(SIN);  %return
 &460   
 &461   Sp(56):  !%prim(56)%longrealfn Cos(%longreal R)
 &462            Do Real Fn(COS);  %return
 &463   
 &464   Sp(57):  !%prim(57)%longrealfn Ln(%longreal R)
 &465            Do Real Fn(LGN);  %return
 &466   
 &467   Sp(58):  !%prim(58)%longrealfn Exp(%longreal R)
 &468            Do Real Fn(EXP);  %return
 &469   
 &470   Sp(59):  !%prim(59)%longrealfn Arctan(%longreal R)
 &471            Do Real Fn(ATN);  %return
 &472      %end
?EOLNEP unused
?EOLNID unused
?NEXTCHEP unused
?READCHEP unused
 &473   
 &474   %routine Call(%integer Tidy)
 &475      {Tidy#0 if the caller is to remove parameters from the stack}
 &476      %record(Stackfm)%name V, Temp, X, W
 &477      %record(Stackfm) Work
 &478      %integer Ep, Flags, Extra, Op, BaseReg
 &479      V     == Stack
 &480      Stack == Stack_Stack
 &481      Flags = V_Flags
 &482      %if Flags&Primitive # 0 %start
 &483         %while V_Params ## Nil %cycle
 &484            V_Params_Stack == Stack
 &485            Stack == V_Params
 &486            V_Params == V_Params_Params
 &487         %repeat
 &488         Special Call(V_Prim)
 &489         Drop(V)
 &490         %return
 &491      %finish
 &492   
 &493      BaseReg = R0
 &494      BaseReg = R1 %if Flags&Answer # 0 %and V_Flags&Defered = 0 %and
 &495 +                      (V_Type = Strings %or V_Type = Records)
 &496      Pass Parameters(V, Extra, BaseReg)
 &497      Hazard All %if Active Registers # 0
 &498   
 &499      Assign Lock = 0                         {no longer safe}
 &500      Attributes = Attributes!Attr Dynamic
 &501   
 &502      Temp == Nil
 &503      %if BaseReg = R1 %start                 {extra parameter for results}
 &504         Temp == Claim Work Area(Item Size(V_Format), V_Type)
 &505         Temp_Format = V_Format
 &506         W == Copy(Temp)
 &507         Amap(W);  Load(W, R0)
 &508         Release and Drop(W)
 &509      %finish
 &510   
 &511      Ep  = V_Disp
 &512      %if Flags&Xproc Spec  # 0 %start        {external Call}
 &513         %if Flags&Prim Proc # 0 %start
 &514            Fail("XP-call")
 &515   !!!      Dir2(Dir xpCall, Ep);  Ca = Ca+4;  Refs = Refs+1
 &516         %else
 &517            X Call(Ep, 0, 1)
 &518         %finish
 &519      %else %if Flags&Parameter # 0 %or V_Base # 0 %or V_Record ## Nil
 &520                                                {procedure parameter call}
 &521         W == Copy(V)
 &522         W_Type = Integers;  W_Form = Direct;  W_Area = 0
 &523         Amap(W)
 &524         Load(W, R4)
 &525         Release and Drop(W)
 &526         Prim(CallP)
 &527      %else %if Flags&Prim Proc # 0
 &528         Fail("P-call")
 &529   !!!   Dir2(Dir pCall, Ep);  Ca = Ca+4;  Refs = Refs+1
 &530      %else                                        {normal internal call}
 &531         %if Flags&Nasty Proc # 0 %start           {must pass an environment}
 &532            Fail("No local display") %if Local Display = 0
 &533            X == Local Integer(Local Display)
 &534            Load Address(X, R8)
 &535            Release and Drop(X)
 &536         %finish
 &537         Dir2(Dir Call, Ep);  Ca = Ca+4;  Refs = Refs+1
 &538      %finish
 &539      Pop Stack(Extra) %if Extra # 0               {restore the stack}
 &540      Forget Everything
 &541   
 &542      %if Flags&Answer # 0 %start                  {set up result descriptor}
 &543         %if Temp == Nil %start
 &544            Temp == Literal(0)
 &545            Temp_Type   = V_Type
 &546            Temp_Format = V_Format
 &547            Temp_Base   = R0
 &548            %if Flags&Defered # 0 %start            {a map}
 &549               Temp_Form = Direct
 &550               Temp_Base = R0
 &551            %else %if Reals <= Temp_Type <= Lreals
 &552               Temp_Base = F0;  Temp_Type = Lreals
 &553            %finish
 &554            Claim(Temp_Base)
 &555         %finish
 &556         Temp_Stack == Stack;  Stack == Temp
 &557      %else %if Flags&Pred Call # 0                 {a predicate}
 &558         Plant1(TEQ, R0, 0, Nothing)                {set CC}
 &559      %finish
 &560      Uncond Jump = Ca %if Flags&Closed # 0
 &561      Drop(V)
 &562   %end
?OP unused
?WORK unused
?TIDY unused
 &563   
 &564   %routine Prim(%integer N)
 &565      %integer For, Reg, Par
 &566      Fail("Prim ") %unless Signal <= N <= Last Prim
 &567      Monitor(Nil, "Prim ".ItoS(N, 0)) %if Diag&MonOperate # 0
 &568      For = Corrupts(N)
 &569      Par = Prim Parameter(N)
 &570      Reg = R0
 &571      %while For # 0 %cycle
 &572         %if For&1 # 0 %start         {prim corrupts this register}
 &573            %if Par&1 = 0 %start      {it isn't a parameter}
 &574               Hazard(Reg)
 &575            %else                     {it is a parameter}
 &576               Hazard(Reg) %if Activity(Reg) > 1
 &577            %finish
 &578            Forget(Reg)               {forget its value}
 &579         %finish
 &580         Reg = Reg+1
 &581         For = For>>1
 &582         Par = Par>>1
 &583      %repeat
 &584      Dir2(Dir Prim, N);  Ca = Ca+4;  Refs = Refs+1
 &585   %end
 &586   %endoffile
 3705  
 3706     %routine Switch Label(%integer Tag)
 3707        Dir2(Dir Slabel, Var(Tag)_Area+Popped Value)
 3708        Uncond Jump = -1
 3709        Assign Lock = 0
 3710        Mark User Label
 3711        Forget Everything
 3712     %end
 3713  
 3714     %routine Switch Jump(%integer Tag)
 3715        %record(Stackfm)%name X
 3716        X == Stack;  Stack == Stack_Stack            {the index}
 3717        Load(X, R1)
 3718        Release and Drop(X)
 3719        Prim(SwJump)
 3720        Dump Word(16_E792F105)                       {LDR_Pc,[R2,R5 %LSL #2]}
 3721        Dir2(Dir Sw Ref, Var(Tag)_Format);  Ca = Ca+4
 3722        Uncond Jump = Ca
 3723     %end
 3724  
 3725     %routine Save Wsp
 3726        %record(Stackfm)%name D
 3727        %if Wsp Save = 0 %start
 3728           Frame = (Frame&(\3))-4
 3729           Wsp Save = Frame
 3730        %finish
 3731        D == Local Integer(Wsp Save);  Plant2(STR, Sp, D);  Release and Drop(D)
 3732     %end
 3733  
 3734     %routine Event Trap(%integer Bits)
 3735              {###################################################}
 3736              {#                    Block(......)                #}
 3737              {#                       ............              #}
 3738              {#                       %on EVENT BITS %start     #}
 3739              {#  Event Label  ->         .......                #}
 3740              {#                          .......                #}
 3741              {#                       %finish                   #}
 3742              {#  Event Body   ->      .......                   #}
 3743              {#                       .......                   #}
 3744              {#                    %end                         #}
 3745  
 3746              {###################################################}
 3747        %integer Lab
 3748        %record(Stackfm)%name D
 3749        Lab = Tag
 3750        Save Wsp
 3751        Jump Forward(Lab, Always)
 3752        Event Bits  = Bits
 3753        Event Body  = Jlab
 3754        Event Label = New Label
 3755        Define Label(Event Label);  Mark User Label
 3756        Forget Everything
 3757        D == Local Integer(Wsp Save);  Plant2(LDR, Sp ,D);  Release and Drop(D)
 3758        Attributes = Attributes!Attr Dynamic
 3759     %end
 3760  
 3761  %routine Signal Event(%integer Event)
 3762     %record(Stackfm)%name E, Sub Event, Extra
 3763     Extra     == Stack
 3764     Sub Event == Extra_Stack
 3765     Stack     == Sub Event_Stack
 3766     E == Literal(Event)
 3767     Load Trio(E, R1, Sub Event, R2, Extra, R3)
 3768     Release and Drop Pair(E, Sub Event)
 3769     Release and Drop(Extra)
 3770     Prim(Signal)
 3771     Uncond Jump = Ca
 3772     Attributes = Attributes!Attr Dynamic
 3773  %end
 3774  
 3775  %include "compare.inc"
 &1     !Revision history:
 &2     
 &3     !  8-Jul-87 PSR test zero was using integer comparison for testing reals (-0)
 &4     !             - comparison of null strings was wrong
 &5     
 &6     {Comparisons}
 &7     
 &8     %routine Set Pending for(%integer V)
 &9        %integer Mask = 0     {bits set for <=>}
 &10             %if Pending = '=' %then Mask = 2_010 {-}%c
 &11  +    %else %if Pending = '#' %then Mask = 2_101 {-}%c
 &12  +    %else %if Pending = '<' %then Mask = 2_100 {-}%c
 &13  +    %else %if Pending = '>' %then Mask = 2_001 {-}%c
 &14  +    %else %if Pending = '(' %then Mask = 2_110 {-}%c
 &15  +    %else %if Pending = ')' %then Mask = 2_011 {-}%c
 &16  +    %else %if Pending = 't' %then Mask = 2_101 {-}%c
 &17  +    %else %if Pending = 'k' %then Mask = 2_010 %else Fail("Bad cc")
 &18       V = -V %and Invert = 0 %if Invert # 0
 &19       Pending = '#'           {false}
 &20       Pending = '=' %if (V = 0 %and Mask&2_010 # 0) {-}%c
 &21  +                  %or (V > 0 %and Mask&2_001 # 0) {-}%c
 &22  +                  %or (V < 0 %and Mask&2_100 # 0)
 &23       Plant1(CMP ! Scc, 0, R0, Just(R0))              {set equal}
 &24    %end
 &25    
 &26    %routine Test Zero(%record(Stackfm)%name V)
 &27       %record(Stackfm)%name W
 &28       %integer Op, X
 &29    
 &30       %routine Test Short Bits(%record(Stackfm)%name V, %integer Mask)
 &31          %integer Op = TST
 &32          %record(Stackfm)%name W
 &33          Mask = Mask&16_FFFF
 &34          V == Copy(V)
 &35          %if Mask&255 = 0 %start      {test the top byte only}
 &36             Advance(V, Bytes, 1)
 &37             Loadup(V)
 &38             Plant1(TST, V_Base, 0, Immediate(Mask>>8)) {test high}
 &39          %else %if Mask <= 255        {test the bottom byte only}
 &40             Advance(V, Bytes, 0)
 &41             Loadup(V)
 &42             Plant1(TST, V_Base, 0, Immediate(Mask))    {test low}
 &43          %else                        {test both}
 &44             W == Copy(V)
 &45             Advance(V, Bytes, 0)      {low byte}
 &46             Advance(W, Bytes, 1)      {high byte}
 &47             Loadup(V);  Loadup(W)
 &48             Plant1(TST,           V_Base, 0, Immediate(Mask&255)) {test low}
 &49             Plant1(TST ! Cond EQ, W_Base, 0, Immediate(Mask>>8))  {test high}
 &50             Release and Drop(W)
 &51          %finish
 &52          Release and Drop(V)
 &53       %end
?OP unused
 &54    
 &55       %routine Test Integer Bits(%record(Stackfm)%name V, %integer Mask)
 &56          %integer X, Op
 &57          Loadup(V)
 &58          Op = TST;  X = 16
 &59          %while Mask # 0 %cycle
 &60             Mask = Mask>>2 %and X = X-1 %while Mask&3 = 0
 &61             Plant1(Op, V_Base, 0, Rot(Mask&255, X&15))
 &62             Mask = Mask>>8;  X = X-4
 &63             Op = Op ! Cond EQ
 &64          %repeat
 &65          Plant1(Op, V_Base, 0, Immediate(0)) %if X = 16  {special for &0????}
 &66       %end
 &67    
 &68       Monitor(V, "Tzero") %if Diag&MonCond # 0
 &69       Optimise(V, 1)
 &70       %if V_Oper # 0 %start
 &71          W == V_Link
 &72          %if (Pending = '=' %or Pending = '#' %or Pending = 't' %or Pending = 'k') {-}%c
 &73  +            %and V_Oper = ANDx %and Iconst(W) %start
 &74             V_Oper = 0;  V_Link == Nil
 &75             %if V_Type = Shorts %start
 &76                Test Short Bits(V, W_Disp)
 &77             %else %if V_Type = Bytes
 &78                Loadup(V);  Plant1(TST, V_Base, 0, Immediate(W_Disp&255))
 &79             %else  {integers}
 &80                Test Integer Bits(V, W_Disp)
 &81             %finish
 &82             Release and Drop(W)
 &83             %return
 &84          %finish
 &85          Loadup(V)
 &86       %finish
 &87       %if V_Type >= Reals %start
 &88          Loadup(V)
 &89          Plant8(CMF ! Small Constant, V_Base, 0)
 &90       %else %if Iconst(V)                    {%if 0=1 ...}
 &91          Set Pending for(V_Disp)
 &92       %else
 &93          Loadup(V)
 &94          Plant1(CMP, V_Base, 0, Nothing)
 &95          %if Pending = '#' %start           {can remember the value}
 &96             Pending Known Register = V_Base
 &97             Pending Known          = 0
 &98          %finish
 &99       %finish
 &100   %end
?X unused
?OP unused
 &101   
 &102   %routine Comp Tostring(%record(Stackfm)%name S, X)
 &103      Amap(S)
 &104      Load Pair(S, R2, X, R1)
 &105      Prim(Cscomp)
 &106   %end
 &107   
 &108   %routine Compare Strings(%record(Stackfm)%name Left, Right)
 &109      %record(Stackfm)%name W
 &110      Evaluate String Expression(Left)  %if  Left_Oper # 0
 &111      Evaluate String Expression(Right) %if Right_Oper # 0
 &112      Simplify(Left)
 &113      Simplify(Right)
 &114      Right == Copy(Right)
 &115      Left  == Copy(Left)
 &116      %if Right_Bias = 1 %start           {rhs null}
 &117         %if Left_Type # Strings %start
 &118            Loadup(Left);  Plant1(CMN, 0, Left_Base, Immediate(1))
 &119         %else %if Left_Bias = 1          {both null}
 &120            Plant1(CMP ! Scc, 0, R0, Just(R0))     {set cc equal}
 &121         %else
 &122            Left_Type = Bytes;  Test Zero(Left)
 &123         %finish
 &124      %else %if  Left_Bias = 1            {lhs null}
 &125         %if Right_Type # Strings %start
 &126            Loadup(Right);  Plant1(CMN, 0, Right_Base, Immediate(1))
 &127         %else
 &128            Right_Type = Bytes;  Test Zero(Right)
 &129         %finish
 &130         Invert = Invert!!Inverted
 &131      %else %if Right_Type # Strings      {rhs a tostring}
 &132         Comp Tostring(Left, Right)
 &133      %else %if Left_Type # Strings       {lhs a tostring}
 &134         Comp Tostring(Right, Left)
 &135         Invert = Invert !! Inverted
 &136      %else                               {normal comparison}
 &137         Amap(Left);  Amap(Right)
 &138         Load Pair(Left, R1, Right, R2)
 &139         Prim(Scomp)
 &140      %finish
 &141      Release and Drop Pair(Left, Right)
 &142   %end
?W unused
 &143   
 &144   %routine Compare Records(%record(Stackfm)%name L, R)
 &145      %record(Stackfm)%name Size
 &146      %integer N, Op
 &147   
 &148      %routine Fix Set(%record(Stackfm)%name L)
 &149         Simplify(L)
 &150         %if L_Members ## Nil %start
 &151            Build Set(L)
 &152         %else %if L_Flags&Null Set # 0
 &153            L_Type = Integers
 &154         %finish
 &155         L_Format = 256//8
 &156      %end
 &157   
 &158      %routine Compare Set(%record(Stackfm)%name L, R, %integer CC)
 &159         Pending = CC
 &160         Amap(L);  Amap(R)
 &161         Load Pair(L, R8, R, R11)
 &162         Prim(Set GE)
 &163      %end
 &164   
 &165      Fix Set(L) %if L_Type = Sets
 &166      Fix Set(R) %if R_Type = Sets
 &167      %if L_Type = Integers %start
 &168         %if R_Type = Integers %start   {two null sets}
 &169            Plant1(CMP ! Scc, 0, R0, Just(R0))     {set cc equal}
 &170         %else
 &171            Invert = Invert!!Inverted
 &172            Compare Records(R, L)
 &173         %finish
 &174         %return
 &175      %finish
 &176      N = Item Size(L_Format);  Fail("Null area?") %if N <= 0
 &177      %if R_Type = Integers %start         {compare set against []}
 &178         Fail("Bad set size") %if N # Set Size
 &179   
 &180            %routine Do Set(%integer Code)
 &181               Pending = Code
 &182               Load Address(L, R0)
 &183               Prim(Set Zero)         {This returns = or # ONLY}
 &184            %end
 &185   
 &186         %if Pending = '=' %or Pending = '#' %start
 &187            Do Set(Pending)
 &188         %else %if Invert = 0
 &189            %if Pending = '>' %start
 &190               Do Set('#')
 &191            %else %if Pending = '<'
 &192               Pending = 128+'0'          {no-op, unconditionally false}
 &193            %else %if Pending = ')'
 &194               Pending = 'F'              {unconditionally true}
 &195            %else %if Pending = '('
 &196               Do Set('=')
 &197            %finish %else Fail("Null/1")
 &198         %else
 &199            %if Pending = '>' %start
 &200               Pending = 128+'0'          {no-op, unconditionally false}
 &201            %else %if Pending = '<'
 &202               Do Set('#')
 &203            %else %if Pending = ')'
 &204               Do Set('=')
 &205            %else %if Pending = '('
 &206               Pending = 'F'              {always true}
 &207            %finish %else Fail("Null/2")
 &208         %finish
 &209         Invert = 0
 &210      %else %if L_Type = Sets = R_Type     {set comparison}
 &211         Fail("Bad set size") %if N # Set Size
 &212         %if Pending = '=' %or Pending = '#' %start
 &213            Amap(L);  Amap(R)
 &214            Load Pair(L, R0, R, R1)
 &215            Prim(Set Equal)
 &216         %else
 &217            {The prim routine gives: cc=0 if set(R8) >= set(R11), cc#0 otherwise}
 &218            %if Pending = '<' %start    {-> if     L>=R }
 &219               Compare Set(L, R, '#')
 &220            %else %if Pending = '>'     {-> if not(L<=R)}
 &221               Compare Set(R, L, '#')
 &222            %else %if Pending = '('     {-> if     L<=R }
 &223               Compare Set(R, L, '=')
 &224            %else %if Pending = ')'     {-> if not(L>=R)}
 &225               Compare Set(L, R, '=')
 &226            %else
 &227               Fail("bad set comparison")
 &228            %finish
 &229         %finish
 &230      %else                                {record comparison - byte arrays?}
 &231         Amap(L);  Amap(R)
 &232         Size == Literal(N)
 &233         Load Trio(L, R1, R, R2, Size, R0)
 &234         Release and Drop(Size)
 &235         Prim(Prim Compare)
 &236      %finish
 &237   %end
?OP unused
 &238   
 &239   %routine Try for Zero(%record(Stackfm)%name V, %integer Mod)
 &240      %integer Old
 &241      Old = Pending
 &242      %if V_Disp = Mod %start
 &243         %if Pending = '<' %start                   {>=1  :: >0}
 &244            Pending = '('
 &245         %else %if Pending = ')'     {<1   :: <=0}
 &246            Pending = '>'
 &247         %finish
 &248      %else %if V_Disp = -Mod
 &249         %if Pending = '>' %start                   {<=-1 :: <0}
 &250            Pending = ')'
 &251         %else %if Pending = '('     {>-1  :: >=0}
 &252            Pending = '<'
 &253         %finish
 &254      %finish
 &255      V_Disp = 0 %if Pending # Old
 &256   %end
 &257   
 &258   %routine Compare Floating(%record(Stackfm)%name Left, Right)
 &259   
 &260      %predicate Suitable Const(%record(Stackfm)%name L, R)
 &261         %integer Op, N
 &262         %false %unless Iconst(R)
 &263         %if 0 <= R_Disp <= 5 %start
 &264            Op = CMF;  N = R_Disp
 &265         %else %if -5 <= R_Disp <= 0
 &266            Op = CNF;  N = -R_Disp
 &267         %else %if R_Disp = 10
 &268            Op = CMF;  N = 7
 &269         %else %if R_Disp = -10
 &270            Op = CNF;  N = 7
 &271         %else
 &272            %false
 &273         %finish
 &274         Load(L, AnyF)
 &275         Plant8(Op ! Small Constant, L_Base, N)
 &276         %true
 &277      %end
 &278   
 &279      %return %if Suitable Const(Left, Right)
 &280      Invert = Invert !! Inverted %and %return %if Suitable Const(Right, Left)
 &281      Load(Left, AnyF)
 &282      Load(Right, AnyF)
 &283      Plant8(CMF, Left_Base, Right_Base)
 &284   %end
 &285   
 &286   %routine Compare(%record(Stackfm)%name Left, Right)
 &287      %integer Lab
 &288      %record(Stackfm)%name W
 &289   
 &290      %routine Do Const(%record(Stackfm)%name A, B)
 &291         %integer N, Op, V
 &292         Loadup(A)
 &293         V = B_Disp
 &294         %if V >= 0 %start
 &295            N = Immediate(V)
 &296            Op = CMP
 &297         %else
 &298            N = Immediate(-V)
 &299            Op = CMN
 &300         %finish
 &301         %if N < 0 %start
 &302            Loadup(B)
 &303            N = Just(B_Base)
 &304            Op = CMP
 &305         %finish
 &306         Plant1(Op, A_Base, 0, N)
 &307         %if Pending = '#' %start
 &308            Pending Known Register = A_Base
 &309            Pending Known          = 0
 &310            Pending Known_Disp     = V;  Pending Known_Type = Integers
 &311         %finish
 &312      %end
 &313   
 &314      Pending Known Register = 0
 &315      Unsigned = 0 %if Code # 128+'?' %and Code # 128+'"'
 &316      %if Pending Tag # 0 %start
 &317         Lab = Pending Tag;  Pending Tag = 0              {beware recursive loops}
 &318         W == Literal(Pending Lit)
 &319         %if (Pending # '>' %and Pending # ')') %or {-}%c
 &320 +           Right_Disp < Pending Lit %or %not Iconst(Right)  %start
 &321            Loadup(Left)                                  {it's going to be used twice}
 &322            Compare(Left, W);  Release and Drop(W)
 &323            Jump Forward(Lab, LT)
 &324         %else
 &325            Unsigned = 10
 &326            Operate(SUBx, Left, W)
 &327            Right_Disp = Right_Disp-Pending Lit
 &328         %finish
 &329      %finish
 &330      %if Left_Type = Strings %or Right_Type = Strings %or {-}%c
 &331 +        Left_Oper = CONCx   %or Right_Oper = CONCx   %start
 &332         Compare Strings(Left, Right)
 &333         %return
 &334      %finish
 &335      %if  Left_Type = Records %or  Left_Type = Sets {-}%c
 &336 +    %or Right_Type = Records %or Right_Type = Sets %start
 &337         Compare Records(Left, Right);  %return
 &338      %finish
 &339   
 &340      %if Iconst(Right) %start
 &341         Try for zero(Right, 1) %unless Floating(Left)
 &342         %if Iconst(Left) %start
 &343            Set Pending for(Left_Disp-Right_Disp)
 &344            %return
 &345         %finish
 &346         %if Right_Disp = 0 %start
 &347            Test Zero(Left);  %return
 &348         %finish
 &349      %else %if Iconst(Left)
 &350         Try for Zero(Left, -1) %unless Floating(Right)
 &351         %if Left_Disp = 0 %start
 &352            Test Zero(Right)
 &353            Invert = Invert!!Inverted
 &354            %return
 &355         %finish
 &356      %finish
 &357   
 &358      %if Floating(Left) %or Floating(Right) %start
 &359         Compare Floating(Left, Right)
 &360      %else
 &361         %if Iconst(Right) %start
 &362            Do Const(Left, Right)
 &363         %else %if Iconst(Left)
 &364            Do Const(Right, Left)
 &365            Invert = Invert !! Inverted
 &366         %else
 &367            Loadup(Left);  Loadup(Right);  Loadup(Left)
 &368            Plant1(CMP, Left_Base, 0, Just(Right_Base))
 &369         %finish
 &370      %finish
 &371   %end
 &372   
 &373   %routine Compare Values
 &374      %record(Stackfm)%name L, R
 &375      R == Stack
 &376      L == R_Stack;  Stack == L_Stack
 &377      Compare(L, R)
 &378      Release and Drop Pair(L, R)
 &379   %end
 &380   
 &381   %routine Compare Double
 &382      %record(Stackfm)%name L, R
 &383      R       == Stack
 &384      L       == R_Stack
 &385      R_Stack == L_Stack
 &386      %if R_Oper # 0 %start                     {beware %if 0 # X&7 # 5 etc}
 &387         %if R_Oper = CONCx %start
 &388            Evaluate String Expression(R)
 &389         %else
 &390            Loadup(R)
 &391         %finish
 &392      %finish
 &393      %if Pending = '>' %and L_Disp >= 0 %and Iconst(L) %and R_Type <= Addrs %start
 &394         {optimise const<=N<=...}
 &395         Readsymbol(Pending)
 &396         Pending Lit = L_Disp
 &397         Pending Tag = Tag
 &398      %else
 &399         Compare(L, R)
 &400      %finish
 &401      Release and Drop(L)
 &402   %end
 &403   
 &404   %routine Compare Addresses
 &405      %record(Stackfm)%name L, R
 &406      R == Stack
 &407      L == R_Stack;  Stack == L_Stack
 &408      Amap(L);  Amap(R)
 &409      Compare(L, R)
 &410      Release and Drop Pair(L, R)
 &411   %end
 &412   
 &413   %routine Stack Condition
 &414      %integer CC
 &415      %record(Stackfm)%name L, R
 &416      R == Stack;  L == R_Stack;  Stack == L_Stack
 &417      Compare(L, R);  Release and Drop Pair(L, R)
 &418      %if       Pending = '='     %then CC = EQ   {-}%c
 &419 +    %else %if Pending = '<'     %then CC = LT   {-}%c
 &420 +    %else %if Pending = '('     %then CC = LE   {-}%c
 &421 +    %else %if Pending = '>'     %then CC = GT   {-}%c
 &422 +    %else %if Pending = ')'     %then CC = GE   {-}%c
 &423 +    %else %if Pending = '#'     %then CC = NE   {-}%c
 &424 +    %else %if Pending = 't'     %then CC = TT   {-}%c
 &425 +    %else %if Pending = 'f'     %then CC = FF   {-}%c
 &426 +    %else %if Pending = 'F'     %then CC = Always {-}%c
 &427 +    %else %if Pending = 128+'0' %then CC = Never {-}%c
 &428 +                                %else Fail("Bad CC")
 &429      Readsymbol(Pending)
 &430      CC = Reverse(CC) %and Invert = 0 %if Invert # 0
 &431      Stack True or False(CC)
 &432   %end
 &433   
 &434   %routine General Compare
 &435      %integer Op
 &436      %record(Stackfm)%name Right, Left, Rlen, Llen
 &437      Rlen  == Stack
 &438      Llen  == Rlen_Stack
 &439      Right == Llen_Stack
 &440      Left  == Right_Stack
 &441      Stack == Left_Stack
 &442      Fail("variable compare") %unless Iconst(Rlen) %and Iconst(Llen)
 &443      %if Rlen_Disp = Llen_Disp %start
 &444         Amap(Left);  Amap(Right)
 &445         Load Trio(Left, R1, Right, R2, Rlen, R0)
 &446         Prim(Prim Compare)
 &447      %else
 &448         Not in Yet
 &449      %finish
 &450      Release and Drop Pair(Rlen, Llen)
 &451      Release and Drop Pair(Right, Left)
 &452   %end
?OP unused
 &453   %endoffile
 3776  
 3777  {Assignment}
 3778  
 3779  %routine General Move
 3780     %record(Stackfm)%name F, T, Flen, Tlen
 3781     Flen  == Stack
 3782     Tlen  == Flen_Stack
 3783     F     == Tlen_Stack
 3784     T     == F_Stack
 3785     Stack == T_Stack
 3786     Load Pair(Tlen, R3, Flen, R4)
 3787     Load Pair(T,    R1, F,    R2)
 3788     Load Pair(Tlen, R3, Flen, R4)
 3789     Load Pair(T,    R1, F,    R2)
 3790     Release and Drop Pair(Flen, Tlen)
 3791     Release and Drop Pair(F, T)
 3792     Prim(GenMove)
 3793     Forget Everything
 3794  %end
 3795  
 3796  %routine Record Assign(%record(Stackfm)%name From, To)
 3797     %integer LenL, LenR, Inc, Mod, Load, R, Aligned = 1, Zero
 3798  
 3799     %routine Record Op
 3800        R = GPR %if R < 0
 3801        Plant2(LDR ! Mod, R, From) %if Load # 0
 3802        Plant2(STR ! Mod, R, To)
 3803     %end
 3804  
 3805     LenL = Item Size(To_Format)
 3806     LenR = Item Size(From_Format)       {note: Var(0)_Format=0 - constants}
 3807     LenL = LenR %if LenL = 0 %or (LenR # 0 %and LenR < LenL)
 3808     %return %if LenL <= 0
 3809     Aligned = 0 %unless LenL&3 = 0 %and Properly Aligned(To, 3)
 3810     Zero = 0
 3811     %if Iconst(From) %start
 3812        Zero = 1
 3813     %else
 3814        Aligned = 0 %unless Properly Aligned(From, 3)
 3815     %finish
 3816     Forget Destination(To)
 3817     Make AutoI(To, Integers)
 3818     Load = 1
 3819     Inc = 4;  Mod = 0                   {assume words}
 3820     %if Aligned = 0 %start              {must use bytes}
 3821        Inc = 1;  Mod = Byte Op
 3822        To_Type = Bytes
 3823     %finish
 3824     %if Zero # 0 %start                 {record = 0}
 3825        Load = 0                         {no load needed}
 3826        Loadup(From)
 3827        R = From_Base
 3828     %else
 3829        Make AutoI(From, To_Type)
 3830        R = -1
 3831     %finish
 3832  
 3833     Repeat(Record Op, Literal(LenL), Inc, NE)
 3834  
 3835  %end
 3836  
 3837  %routine Set Assign(%record(Stackfm)%name From, Dest)
 3838     %record(Memberfm)%name M, X
 3839     %integer Op = From_Oper, Fn
 3840     %record(Stackfm)%name W, Index
 3841     %record(Stackfm)%name To == Copy(Dest)
 3842  
 3843     Build Set(From) %if From_Members ## Nil
 3844     W == From_Link
 3845     %if W ## Nil %start
 3846        From_Link == Nil;  From_Oper = 0
 3847        %if From_Flags&Null Set # 0 %start
 3848           From == W
 3849        %else
 3850           Fail("Bad set operator") %if Op # RADDx %c
 3851+                                  %and Op # RSUBx %c
 3852+                                  %and Op # RMULx
 3853           %if W_Flags&Null Set = 0 %start
 3854              %unless Same(From, To) %start
 3855                 From_Oper = Op;  From_Link == W;  Loadup(From)
 3856                 Set Assign(From, To)
 3857                 Release and Drop(To)
 3858                 %return
 3859              %finish
 3860              Build Set(W) %if W_Members ## NIL %and %c
 3861+                            (W_Members_Items > 2 %or Op = RMULx)
 3862              Load Address(To, R8)
 3863              %if Op # RMULx %and W_Members ## Nil %start
 3864                 M == W_Members;  W_Members == Nil
 3865                 %while M ## Nil %cycle
 3866                    X == M;  M == M_Link
 3867                    Load Pair(To, R8, X_A, R1)
 3868                    %if X_B ## Nil %start
 3869                       Load(X_B, R0)
 3870                       Load Pair(To, R8, X_A, R1)
 3871                       Release and Drop(X_B)
 3872                       %if Op = RADDx %then Fn = Set Bits %else Fn = Clear Bits
 3873                    %else %if Op = RADDx
 3874                       Fn = Set Bit
 3875                    %else {%if Op = RSUBx}
 3876                       Fn = ClearBit
 3877                    %finish
 3878                    Release and Drop(X_A);  Dispose(X)
 3879                    Prim(Fn)
 3880                 %repeat
 3881                 Release and Drop Pair(W, To)
 3882              %else
 3883                 Amap(W);  Load Pair(To, R8, W, R11)
 3884                 Release and Drop(W)
 3885                 %if Op = RADDx %then Fn = Set Add %else %c
 3886+                %if Op = RSUBx %then Fn = Set Sub       %c
 3887+                               %else Fn = Set Inter
 3888                 Prim(Fn)
 3889                 Release and Drop(To)
 3890              %finish
 3891              %return
 3892           %finish
 3893        %finish
 3894     %finish
 3895     Release and Drop(W) %unless W == Nil
 3896  
 3897     Forget Destination(To)
 3898     %if From_Flags&Null Set # 0 %start
 3899        %routine Zero(%integer R)
 3900           %record(Stackfm)%name W == Literal(0)
 3901           Load(W, R);  Release and Drop(W)
 3902        %end
 3903        Load Address(To, R8)
 3904        Zero(R0);  Zero(R1);  Zero(R2);  Zero(R3)
 3905        Plant4(STM ! IA ! Write Back,   To_Base, 16_000F)
 3906        Plant4(STM ! IA,                To_Base, 16_000F)
 3907     %else
 3908        {Note: if set expressions are about it is likely that the address}
 3909        {      of FROM is in R8, so load R11 first to catch it}
 3910        Load Address(From, R11)
 3911        Load Address(To, R8)
 3912        Hazard(R0);  Hazard(R1);  Hazard(R2);  Hazard(R3)
 3913        Hazard(R4);  Hazard(R5);  Hazard(R6);  Hazard(R7)
 3914        Plant4(LDM ! IA, From_Base, 16_00FF)
 3915        Plant4(STM ! IA,   To_Base, 16_00FF)
 3916        Forget(R0);  Forget(R1);  Forget(R2);  Forget(R3)
 3917        Forget(R4);  Forget(R5);  Forget(R6);  Forget(R7)
 3918     %finish
 3919     Release and Drop(To)
 3920  %end
?INDEX unused
 3921  
 3922  %routine Resolve(%integer Flag)
 3923     {S -> A.(B).C}
 3924     %integer Lab, InLab = 0, Pend, N
 3925     %record(Stackfm)%name S, A, B, C
 3926  
 3927     N = 0
 3928     %if Flag&1 # 0 %start
 3929        C == Stack;  Stack == Stack_Stack
 3930     %else
 3931        N = N!1
 3932        C == Nil
 3933     %finish
 3934     B == Stack %and Stack == Stack_Stack
 3935     %if Flag&2 # 0 %start
 3936        A == Stack;  Stack == Stack_Stack
 3937     %else
 3938        N = N!2
 3939        A == Nil
 3940     %finish
 3941     S == Stack;  Stack == Stack_Stack
 3942  
 3943     Evaluate String Expression(B) %if B_Oper # 0
 3944     Fix Tostring(B) %if B_Type <= Addrs
 3945     Amap(S);  Amap(B)
 3946     Load Pair(S, R1, B, R2)
 3947     Release and Drop Pair(S, B)
 3948     Prim(Sres)
 3949     %if Flag&4 = 0 %start                {unconditional}
 3950        Prim(Resflop)
 3951     %else                                {conditional}
 3952        Fail("corrupt resolution") %if Pending # 't' %and Pending # 'k'
 3953        Pend = Pending;  Readsymbol(Pending)
 3954        InLab = Tag
 3955        %if Pend = 't' %start
 3956           Lab = New Label;  Jump to(Lab, NE)
 3957        %else
 3958           Jump Forward(InLab, NE);  InLab = 0
 3959        %finish
 3960     %finish
 3961     Claim(R1);  Claim(R7)   {left fragment}
 3962     Claim(R3);  Claim(R6)   {right fragment}
 3963     %if A ## Nil %start
 3964        Load Address(A, R2);  Prim(Frag1)
 3965        Release and Drop(A)
 3966     %finish
 3967     %if C ## Nil %start
 3968        Load Address(C, R2);  Prim(Frag2)
 3969        Release and Drop(C)
 3970     %finish
 3971     Release(R1);  Release(R7)
 3972     Release(R3);  Release(R6)
 3973     %if InLab # 0 %start
 3974        Jump Forward(InLab, Always)
 3975        Define Label(Lab)
 3976     %finish
 3977  %end
 3978  
 3979  %include "strings.inc"
 &1     %routine Evaluate String Expression(%record(Stackfm)%name V)
 &2        %record(Stackfm)%name W
 &3        W == Claim Work Area(256, Strings)
 &4        String Assign(V, W)
 &5        Replace(V, W)
 &6     %end
 &7     
 &8     %routine String Assign(%record(Stackfm)%name R, L)
 &9        %record(Stackfm)%name W, LL, DelayV, Z
 &10       %integer Conc Length = 1, All Const = 1, Reg, Delay = 0, Len = 0
 &11       %integer Here, Lab, N
 &12       %string(255) Val = ""
 &13    
 &14       %predicate Safe(%record(Stackfm)%name Target, Chain)
 &15          %cycle
 &16             Conc Length = Conc Length+1
 &17             Conc Length = -1000 %if Chain_Type > Addrs
 &18             All Const = 0 %unless Iconst Item(Chain)
 &19             Val = Val.Tostring(Chain_Disp&255) %if All Const # 0
 &20             %false %if Same(Target, Chain) %or (Target_Index ## Nil %and
 &21  +                                               Chain_Index ## Nil)
 &22             Chain == Chain_Link
 &23          %repeat %until Chain == Nil
 &24          %true
 &25       %end
 &26    
 &27       %routine Move1
 &28          Forget(L_Base);  Forget(R_Base)
 &29          Simple(R, L)
 &30       %end
 &31    
 &32    
 &33       Forget Destination(L)
 &34       %if R_Oper = 0 %start
 &35          {**********************************}
 &36          {*** Simple assignment:   S = T ***}
 &37          {**********************************}
 &38    
 &39          N = R_Bias
 &40          %if N # 0 %start                            {constant string}
 &41             %if N = 1 %start                         {L = ""}
 &42                L == Copy(L);  L_Type = Bytes
 &43                R == Literal(0)
 &44                Simple(R, L)
 &45             %else %if N < 0                          {implied tostring}
 &46       Ctos:    L == Copy(L)
 &47                Advance(L, Bytes, 1);   Simple(R, L)  {plug the character}
 &48                R == Literal(1)
 &49                Advance(L, Bytes, -1);  Simple(R, L)  {plug the length}
 &50             %else                                    {move in N bytes}
 &51                L == Copy(L);  Make AutoI(L, Bytes)
 &52                R == Copy(R);  Make AutoI(R, Bytes)
 &53                Repeat(Move1, Literal(N), 1, NE)      {NOTE length(S)+1}
 &54             %finish
 &55             Release and Drop Pair(L, R)
 &56          %else %if R_Type <= Addrs             {implied tostring}
 &57             ->Ctos %if Iconst Item(R)
 &58             W == Copy(L);  Advance(W, Bytes, 1)
 &59             Simple(R, W);  Release and Drop(W)
 &60             L == Copy(L);  L_Type = Bytes
 &61             Move Literal(1, L);                          Release and Drop(L)
 &62          %else                                  {Variable string}
 &63             L == Copy(L);  Make AutoI(L, Bytes)
 &64             R == Copy(R);  Make AutoI(R, Bytes)
 &65             W == Copy(R);  W_Form = Direct
 &66             Repeat(Move1, W, 1, GE)
 &67             Release and Drop Pair(L, R)
 &68          %finish
 &69          %return
 &70       %finish
 &71    
 &72       {**************************************}
 &73       {*** Complex assignment: S = A.B... ***}
 &74       {**************************************}
 &75    
 &76          %routine Assign via Work
 &77             %record(Stackfm)%name W
 &78             W == Claim Work Area(255, Strings)
 &79             String Assign(R, W)
 &80             String Assign(W, L)
 &81             Release and Drop(W)
 &82          %end
 &83    
 &84       W == R_Link
 &85       %unless Safe(L, W) %start
 &86          Assign via Work;  %return
 &87       %finish
 &88    
 &89       R_OpLink = 0
 &90       %if Conc Length > 0 %and R_Type <= Addrs %start         {all tostrings}
 &91          L == Copy(L)
 &92          All Const = 0 %unless Iconst Item(R)                 {first variable}
 &93          %if All Const # 0 %start                             {it's in VAL}
 &94             Value_String = Tostring(R_Disp&255).Val           {don't forget the first}
 &95             Z == Const String
 &96             String Assign(Z, L)
 &97             Release and Drop(Z)
 &98             {all done, but fall through to drop descriptors}
 &99          %else                                {some dynamic tostrings}
 &100            Make AutoI(L, Bytes)
 &101            Move Literal(Conc Length, L)      {move in the total length}
 &102         %finish
 &103   
 &104            %routine Assign Part
 &105               R_OpLink = 0
 &106               Simple(R, L) %if All Const = 0
 &107            %end
 &108   
 &109         Assign Part
 &110         %cycle
 &111            R == W
 &112            W == R_Link
 &113            Assign Part
 &114            Release and Drop(R)
 &115         %repeat %until W == Nil
 &116         Release and Drop(L)
 &117         %return
 &118      %finish
 &119   
 &120         %routine Concat(%record(Stackfm)%name Source)
 &121            %record(Stackfm)%name Dest
 &122            Source_Oplink = 0
 &123            %if Source_Type <= Addrs %start      {Tostring(X)}
 &124               Dest == Register(R2);  Dest_Type = Bytes;  Dest_Form = AutoI
 &125               Simple(Source, Dest)
 &126               Release and Drop(Dest)
 &127               %return
 &128            %finish
 &129            {perhaps optimise if source length known}
 &130            Load Address(Source, R3)
 &131            Prim(Sconc)
 &132         %end
 &133   
 &134      LL == Copy(L);  Amap(LL)
 &135      %if Same(L, R) %start                            {S = S.W.....}
 &136         %if W_Link == Nil %and W_Type <= Addrs %start {S = S."*"}
 &137            Loadup(LL);  LL_Type = Bytes;  LL_Form = Direct
 &138            R == Copy(LL)                            {length pointer}
 &139            Z == Copy(LL)
 &140            Operate(ADDx, Z, Literal(1))             {length+1}
 &141            Loadup(Z)                                {new length}
 &142            LL_Index == Copy(Z);  LL_Xsize = 1       {charno descriptor}
 &143            Simple(W, LL)                            {plug in character}
 &144            Simple(Z, R)                             {plug in new length}
 &145            Release and Drop Pair(W, Z)
 &146            Release and Drop Pair(LL,R)
 &147            %return
 &148         %finish
 &149         Load(LL, R2)                                {pointer to length}
 &150         Z == Copy(LL);  Z_Type = Bytes;  Z_Form = AutoI
 &151         Load(Z, R1)                                 {current length}
 &152         R == Copy(LL);  Load(R, R0);  Drop(R)       {copy of @charno(s, 1)}
 &153         LL_Index == Z;  LL_Xsize = 1
 &154         Load(LL, R2);  Release(R2)                  {pointer past S}
 &155         Forget(R2);  Activity(R2) = -1              {lock R2}
 &156         LL_Base = R0                                {pointer for plugging length}
 &157      %else
 &158         DelayV == Nil
 &159         %while R_Type <= Addrs %cycle               {pull of leading tostrings}
 &160                                                     {NOTE - the case of all}
 &161                                                     {tostrings handled above}
 &162            Delay = Delay+1
 &163            R_Oper = 0
 &164            R_Link == DelayV;  DelayV == R           {reverse them}
 &165            R == W
 &166            W == W_Link
 &167         %repeat
 &168         Operate(ADDx, LL, Literal(Delay+1))         {onto first real char space}
 &169         Load(LL, R2)
 &170         Load(LL, R0)                                {copy for pluging length}
 &171         Forget(R2);  Activity(R2) = -1              {lock R2}
 &172         %if R ## Nil %start
 &173            Concat(R)                                {first using Reg}
 &174            Release(R_Base);  R_Base = 0
 &175            Drop(R) %if Delay # 0
 &176         %else
 &177            Len = Delay                              {final length}
 &178         %finish
 &179      %finish
 &180      %while W ## Nil %cycle
 &181         R == W
 &182         W == R_Link;  Concat(R)             {remainder using R2 set by MOVS}
 &183         Release and Drop(R)                 {Note first is left to be released}
 &184      %repeat                                {     by the caller}
 &185      LL_Type = Bytes;  LL_Form = AutoD
 &186      %while Delay # 0 %cycle
 &187         Delay = Delay-1
 &188         R == DelayV;  DelayV == R_Link;  R_Link == Nil
 &189         Simple(R, LL)
 &190         Release and Drop(R) %if Delay # 0
 &191      %repeat
 &192      %if Len = 0 %start                     {final length unknown}
 &193         Plant1(SUB, R2, R2, Just(R0))
 &194         Plant2(STR, R2, LL)
 &195         Release and Drop(LL)
 &196         LL == Copy(L);  LL_Type = Bytes
 &197         Remember(R2, LL)
 &198      %else                                  {final length known}
 &199         Move Literal(Len, LL)               {plug the length directly}
 &200      %finish
 &201      Release and Drop(LL)
 &202      Activity(R2) = 0                        {unlock R2}
 &203   %end
?LAB unused
?HERE unused
?REG unused
 &204   %endoffile
 3980  %include "store.inc"
 &1     !Revision history:
 &2     
 &3     !  3-Jul-87 PSR corrected assigning longreal values to real locations
 &4     !             - string(*)names were not being passed to %names properly
 &5     
 &6     %routine Store(%record(Stackfm)%name R, L)
 &7        %unless R_Oper = 0 %and Same(L, R) %start
 &8           %if L_Type = Records %start
 &9              Record Assign(R, L)
 &10          %else %if L_Type = Strings
 &11             String Assign(R, L)
 &12          %else %if L_Type = Sets
 &13             Set Assign(R, L)
 &14          %else
 &15             Move(R, L)
 &16          %finish
 &17       %finish
 &18    %end
 &19    
 &20    %routine Assign Procedure(%record(Stackfm)%name R, L)
 &21       {A procedure parameter is a pointer to a tw0-word vector}
 &22       {There are four cases}
 &23       {1. The procedure is an external  - <Ep><?>}
 &24       {2. The procedure is a parameter  - pass the pointer}
 &25       {3. The procedure is a safe local - pass <Ep><?> and mark the parameter}
 &26       {                                   as needing an external entry}
 &27       {4. The procedure is dangerous    - pass <Ep><Display> and work hard}
 &28       %integer Mask
 &29       %record(Stackfm)%name W, V
 &30       %if R_Flags&Xproc Spec # 0 %start      {case 1 - an external}
 &31          Hazard(R2)
 &32          Dir2(Dir xThunk, R_Disp)            {         load @vector into R13}
 &33          Refs = Refs+1;  Ca = Ca+4
 &34          R == Register(R13)
 &35       %else %if R_Flags&Parameter # 0        {case 2 - already a parameter}
 &36          R_Type = Integers;  R_Form = Direct;  R_Area = 0
 &37          R == Copy(R)
 &38       %else %if R_Flags&XprocDef # 0         {case 3 - simplified}
 &39          Hazard(R13)
 &40          Dir2(Dir Thunk, R_Disp)             {         load @vector into R13}
 &41          Refs = Refs+1;  Ca = Ca+4
 &42          R == Register(R13)
 &43       %else                                  {cases 3 & 4}
 &44          Hazard(R13)
 &45          Dir2(Dir Thunk, R_Disp)             {Load @Ep into R13}
 &46          Ca = Ca+4;  Refs = Refs+1
 &47          Claim(R13)
 &48          Mask = 2_0010 0100 0000 0000        {R10, R13 = Sb, Ep}
 &49          W == NIL
 &50          %if R_Flags&Nasty Proc # 0 %start   {case 4 - a dangerous internal}
 &51             Frame = Frame-4
 &52             W == Literal(Local Display);  W_Base = Local
 &53             Load(W, R14)
 &54             Mask = 2_0110 0100 0000 0000     {R10, R13, R14 = Sb, Ep, Env}
 &55          %finish
 &56          Frame = Frame&(\3)-8
 &57          R == Local Integer(Frame);  Loadup Address(R)
 &58          Plant4(STM ! IA, R_Base, Mask)
 &59          Release(R13)
 &60          Release and Drop(W) %if W ## NIL
 &61       %finish
 &62       L_Type = Integers
 &63       Simple(R, L)
 &64       Release and Drop(R)
 &65    %end
?V unused
 &66    
 &67    %routine Assign Arrayname(%record(Stackfm)%name Array, To)
 &68       %record(Stackfm)%name DopeVector
 &69       Array_Type = Integers          {the header contains integer addresses}
 &70       To   _Type = Integers
 &71       %if Array_Flags&(Arrayname!Static) = 0 %start     {in a record}
 &72          %if Array_Adata == Nil %start
 &73             DopeVector == Literal(0)
 &74          %else
 &75             DopeVector == Literal(Array_Adata_DV)
 &76             DopeVector_Area = Constant Area
 &77          %finish
 &78          Amap(Array)
 &79       %else
 &80          DopeVector == Copy(Array)
 &81          Advance(DopeVector, Integers, Word Length)
 &82       %finish
 &83       Simplify(To)
 &84       Advance(To, Integers, Word Length)
 &85       Simple(DopeVector, To);  Release and Drop(DopeVector)  {dope-vector}
 &86       Advance(To, Integers,-Word Length)
 &87       Simple(Array, To)                                      {array0}
 &88    %end
 &89    
 &90    %integerfn Select Best(%record(Stackfm)%name From, To, %integer Default)
 &91       %record(Stackfm)%name W
 &92       %integer Reg
 &93       %result = Default %if InReg(From)
 &94       W == Copy(To);  Optimise(W, 1)
 &95       %if InReg(W) %and Activity(W_Base) = 1 %then Reg = W_Base {-}%c
 &96  +                                           %else Reg = Default
 &97       Release and Drop(W)
 &98       %result = Reg
 &99    %end
 &100   
 &101   %routine Move(%record(Stackfm)%name From, To)
 &102      %record(Stackfm)%name Bf1, Bf2, Bt1, Bt2, W
 &103      %integer R, Pa, N, Best, Op
 &104      %if From_Oper = ADDx %and Pending Auto # 0 %start
 &105         W == From_Link
 &106         %if Iconst(W) %and -4095 <= W_Disp <= 4095 %start
 &107            From_Oper = 0;  From_Link == NIL
 &108            Pa = Pending Auto               {the optimise will destroy it}
 &109            Optimise(From, 1)
 &110            %if Inreg(From) %and From_Base = Pa {-}%c
 &111 +              %and (Pending Auto N = 0 %or |W_Disp>>2| <= 255) %start
 &112               Dir3(Dir Modify, Ca-Pending Auto Ca, W_Disp>>Pending Auto N)
 &113               Forget(Pa)
 &114               Drop(W)
 &115            %else
 &116               From_Oper = ADDx;  From_Link == W
 &117            %finish
 &118         %finish
 &119      %finish
 &120      %if From_Type = Shorts %and (From_Oper = ANDx %or From_Oper = BICx) {-}%c
 &121 +                           %and To_Type = Integers                      {-}%c
 &122 +                           %and Iconst(From_Link) %start
 &123         N = From_Link_Disp
 &124         N = \N %if From_Oper = BICx
 &125         %if N&16_FFFF0000 = 0 %start
 &126            Release and Drop(From_Link)
 &127            From_Oper = 0;  From_Link == NIL
 &128            %if N <= 255 %start
 &129               Advance(From, Bytes, 0)                     {low byte}
 &130               Operate(ANDx, From, Literal(N)) %if N # 255
 &131            %else %if N&255 = 0
 &132               Release and Drop(From_Link)
 &133               From_Oper = 0;  From_Link = 0
 &134               Advance(From, Bytes, 1)  {high byte}
 &135               Operate(ANDx, From, Literal(N>>8)) %if N>>8 # 255
 &136               Operate(LSHx, From, Literal(8))
 &137            %else
 &138               Best = Select Best(From, To, Any)
 &139               Bf2 == Copy(From);  Advance(Bf2, Bytes, 1)  {high byte}
 &140               Operate(ANDx, Bf2, Literal(N>>8)) %if N>>8 # 255
 &141               Advance(From, Bytes, 0)  {low byte}
 &142               Operate(ANDx, From, Literal(N&255)) %if N&255 # 255
 &143               Loadup(Bf2);  Load Safely(From, Best)
 &144               Loadup(Bf2);  Load Safely(From, Best)       {in case of hazard}
 &145               Plant1(ORR, From_Base, From_Base, Ishift(Bf2_Base, 8, Logical Left))
 &146               Release and Drop(Bf2)
 &147            %finish
 &148         %finish
 &149      %finish
 &150      %if To_Type = Shorts %start
 &151         %if Iconst(From) %start
 &152            Bf1 == Literal(From_Disp&255)               {low byte}
 &153            Bf2 == Literal(From_Disp>>8&255)            {high byte}
 &154         %else %if From_Type = Shorts %and From_Oper = 0
 &155            %if From_Index ## NIL %or From_Record ## NIL %start
 &156               Loadup Address(From);  From_Type = Shorts;  From_Form = Direct
 &157            %finish
 &158            Bf1 == Copy(From);  Advance(Bf1, Bytes, 0)  {low byte}
 &159            Bf2 == Copy(From);  Advance(Bf2, Bytes, 1)  {high byte}
 &160         %else %if From_Type = Bytes %and From_Oper = 0
 &161            Bf1 == Copy(From);  Advance(Bf1, Bytes, 0)  {low byte}
 &162            Bf2 == Literal(0)                           {high byte}
 &163         %else
 &164            Loadup(From)
 &165            Bf1 == Copy(From)
 &166            Bf2 == Copy(From);  Operate(RSHx, Bf2, Literal(8))
 &167         %finish
 &168         Bt1 == Copy(To);    Advance(Bt1, Bytes, 0)  {low byte}
 &169         Bt2 == Copy(To);    Advance(Bt2, Bytes, 1)  {high byte}
 &170         Move(Bf2, Bt2)                              {do the [b+1] side first}
 &171         Move(Bf1, Bt1)                              {and the [b+0] side last}
 &172         Release and Drop Pair(Bf1, Bt1)
 &173         Release and Drop Pair(Bf2, Bt2)
 &174      %else %if To_Type = Bytes
 &175         From_Type = Bytes %if From_Oper = 0 %and From_Type = Shorts
 &176         Simplify(To)
 &177         Loadup(From)
 &178         Plant2(STR ! Byte Op, From_Base, To)
 &179      %else %if To_Type = Lreals
 &180         Best = Select Best(From, To, AnyF)
 &181         Simplify(To)
 &182         Load(From, Best)
 &183         Plant6(STFD, From_Base, To)
 &184      %else %if To_Type = Reals
 &185         %if Iconst(From) %and (-5 <= From_Disp <= 5 %or From_Disp =  10 {-}%c
 &186 +                                                   %or From_Disp = -10) %start
 &187            Op = MVF
 &188            N = From_Disp
 &189            Op = MNF %and N = -N %if N < 0
 &190            N = 7 %if N = 10
 &191            R = FPR
 &192            Plant9(Op ! Small Constant, 0, R, N)
 &193            Plant6(STFS, R, To)
 &194         %else %if From_Form = Direct %and From_Oper = 0 %and From_Type = Reals
 &195              To == Copy(To);      To_Type = Integers
 &196            From == Copy(From);  From_Type = Integers
 &197            Move(From, To)
 &198            Forget(From_Base)
 &199            Release and Drop Pair(From, To)
 &200         %else
 &201            Simplify(To)
 &202            Load(From, AnyF)
 &203            Plant6(STFS, From_Base, To)           {corrected for R0002.IMP}
 &204         %finish
 &205      %else
 &206         Best = Select Best(From, To, Any)
 &207         Simplify(To)
 &208         Load(From, Best)
 &209         Plant2(STR, From_Base, To)
 &210      %finish
 &211   %end
 &212   
 &213   %routine Move Literal(%integer Value, %record(Stackfm)%name To)
 &214      %record(Stackfm)%name W == Literal(Value)
 &215      Simple(W, To)
 &216      Release and Drop(W)
 &217   %end
 &218   
 &219   %routine Move Biased(%record(Stackfm)%name From, To, %integer Bias)
 &220      From == Copy(From)
 &221      To   == Copy(To)
 &222      Advance(From, Integers, Bias) %if From_Form = Direct
 &223      Advance(To,   Integers, Bias)
 &224      Move(From, To)
 &225      Release and Drop Pair(From, To)
 &226   %end
 &227   
 &228   %routine Store Address(%record(Stackfm)%name R, L, %integername Extra)
 &229      %record(Stackfm)%name W
 &230      %integer Rt, Format
 &231      %if L_Type = Generals %start
 &232         L_Type = Integers                  {really three of them}
 &233         Amap(L) %unless L_Form = AutoD
 &234         Format = R_Format
 &235         Rt = R_Type
 &236         Amap(R)
 &237         %if Rt = Generals %start
 &238            Move Biased(R, L, WordLength*2)
 &239            Move Biased(R, L, WordLength*1)
 &240            Move       (R, L)
 &241         %else
 &242            W == Literal(Type Code(Rt))
 &243            Move Biased(W, L, Wordlength*2)
 &244            Release and Drop(W)
 &245            %if Rt = Strings %and R_Form = Direct %and Format = 1 %start {(*)}
 &246               Move Biased(R, L, Wordlength)
 &247               Move       (R, L)
 &248            %else
 &249               W == Literal(Item Size(Format))
 &250               Move Biased(W, L, Wordlength);  Release and Drop(W)
 &251               Move       (R, L)
 &252            %finish
 &253         %finish
 &254         Extra = Extra+12
 &255      %else %if L_Form = Proc
 &256         Assign Procedure(R, L)
 &257         Extra = Extra+4
 &258      %else %if L_Flags&Arrayname # 0
 &259         Assign Arrayname(R, L)
 &260         Extra = Extra+8
 &261      %else %if L_Type = Strings %and L_Format = 1
 &262         N = R_Format
 &263         Amap(L)
 &264         Amap(R)
 &265         %if N = 1 %and R_Form # Address %start                  {string(*)name}
 &266            Move Biased(R, L, Wordlength)
 &267            Move       (R, L)
 &268         %else
 &269            W == Literal(N)
 &270            Move Biased(W, L, Wordlength);  Release and Drop(W)
 &271            Move       (R, L)
 &272         %finish
 &273         Extra = Extra+8
 &274      %else
 &275         %if L_Form = AutoD %then L_Type = Integers {-}%c
 &276 +                          %else Amap(L)
 &277         Amap(R)
 &278         Store(R, L)
 &279         Extra = Extra+4
 &280      %finish
 &281   %end
 &282   
 &283   %routine Jam Transfer(%record(Stackfm)%name L, R)
 &284      %integer N, Type
 &285      %record(Stackfm)%name M
 &286      Type = L_Type
 &287      %if Type # Strings %start                  {just omit the remember}
 &288         Jamit = 1;  Store(R, L);  Jamit = 0
 &289         Forget Destination(L)
 &290      %else
 &291         N = L_Format-1                          {maximum length}
 &292         Evaluate String Expression(R) %if R_Oper # 0
 &293         Amap(L);  Amap(R)
 &294         %if N <= 0 %start                       {string(*)%name}
 &295            M == Copy(L)
 &296            M_Disp = M_Disp+Word Length;  M_Type = Integers
 &297         %else
 &298            M == Literal(N+1)
 &299         %finish
 &300         Load Trio(L, R2, R, R1, M, R0)
 &301         Prim(Sjam)
 &302         Release and Drop(M)
 &303      %finish
 &304   %end
 &305   
 &306   %routine Assign(%integer How)
 &307      %integer X = 0
 &308      %record(Varfm)%name V
 &309      %record(Stackfm)%name L, R
 &310      R == Stack
 &311      L == R_Stack;  Stack == L_Stack
 &312      %if Diag&MonMove # 0 %start
 &313         Monitor(L, "A-L")
 &314         Monitor(R, "A-R")
 &315      %finish
 &316      %if How = Equals %start
 &317         Store(R, L)
 &318      %else %if How = EqualsEquals
 &319         Store Address(R, L, X)
 &320      %else
 &321         Jam Transfer(L, R)
 &322      %finish
 &323      %if Assign Lock # 0 %and L_Varno # 0 %start
 &324         V == Var(L_Varno)
 &325         V_Flags = V_Flags!Known Ass
 &326      %finish
 &327      Release and Drop Pair(R, L)
 &328   %end
 &329   
 &330   %routine Assign Parameter
 &331      %record(Stackfm)%name Par
 &332      Par          == Stack                                {the parameter}
 &333      Stack        == Par_Stack                            {the procedure}
 &334        Par_Params == Stack_Params
 &335      Stack_Params == Par
 &336      Stack_Extra = Stack_Extra-1 %unless Stack_Extra = 0  {beware of C}
 &337      Par_Varno   = Stack_Extra
 &338   %end
 &339   
 &340   %record(Stackfm)%map To Temp(%record(Stackfm)%name V, %integer Size)
 &341      %record(Stackfm)%name W
 &342      W == Claim Work Area(Size, Strings)
 &343      String Assign(V, W)
 &344      Release and Drop(V)
 &345      %result == W
 &346   %end
 &347   
 &348   {%include "pparam.inc"
 &349   %endoffile
 3981  %include "pparam.inc"  {moved out of store.inc}
 &1     !Revision history:
 &2     !
 &3     ! C-0087  20-Jul-88 PSR Changed register processing to fix R(r*r, r*r,..) bug
 &4     ! 0.9  15-Jan-88 PSR Removed %namearray for transputer work
 &5     
 &6     %record(Stackfm)%map Procedure Items(%record(Stackfm)%name R)
 &7        {A procedure parameter is a pointer to a tw0-word vector}
 &8        {There are four cases}
 &9        {1. The procedure is an external  - <Ep><?>}
 &10       {2. The procedure is a parameter  - pass the pointer}
 &11       {3. The procedure is a safe local - pass <Ep><?> and mark the parameter}
 &12       {                                   as needing an external entry}
 &13       {4. The procedure is dangerous    - pass <Ep><Display> and work hard}
 &14       %integer Mask
 &15       %record(Stackfm)%name Ep, Env
 &16       Env == NIL
 &17       %if R_Flags&Xproc Spec # 0 %start      {case 1 - an external}
 &18          Min SB = Min SB-4
 &19          Ep == Local Integer(Min SB);  Ep_Base = SB
 &20          Dir3(Dir xThunk, R_Disp, Ep_Disp)   {relocate entry pointer}
 &21       %else %if R_Flags&Parameter # 0        {case 2 - already a parameter}
 &22                                              {R defines <env><ep> pair}
 &23          R_Type = Integers;  R_Form = Direct;  R_Area = 0
 &24          Env == Copy(R)
 &25          Ep == Copy(Env);  Advance(Ep, Integers, 4)
 &26       %else
 &27          %if R_Flags&XprocDef = 0 %and R_Flags&Nasty Proc # 0 %start
 &28             {case 3 - not a dangerous internal}
 &29             Env == Local Integer(Local Display);  Amap(Env)
 &30          %finish
 &31          Min SB = Min SB-4
 &32          Ep == Local Integer(Min SB);  Ep_Base = SB
 &33          Dir3(Dir Thunk, R_Disp, Ep_Disp)     {relocate entry pointer}
 &34          Refs = Refs+1
 &35       %finish
 &36       Env == Literal(0) %if Env == NIL
 &37       Env_Prim    = Integers;  Ep_Prim    = Integers
 &38       Env_Params == Ep;        Ep_Params == NIL
 &39       %result == Env
 &40    %end
?MASK unused
 &41    
 &42    %record(Stackfm)%map Arrayname Items(%record(Stackfm)%name Array)
 &43       %record(Stackfm)%name DopeVector
 &44       Array == Copy(Array)
 &45       Array_Type = Integers          {the header contains integer addresses}
 &46       %if Array_Flags&(Arrayname!Static) = 0 %start     {in a record}
 &47          %if Array_Adata == Nil %start
 &48             DopeVector == Literal(0)
 &49          %else
 &50             DopeVector == Literal(Array_Adata_DV)
 &51             DopeVector_Area = Constant Area
 &52          %finish
 &53          Amap(Array)
 &54       %else
 &55          DopeVector == Copy(Array)
 &56          Advance(DopeVector, Integers, Word Length)
 &57       %finish
 &58       Array_Prim    = Integers;    DopeVector_Prim    = Integers
 &59       Array_Params == Dopevector;  Dopevector_Params == NIL
 &60       %result == Array
 &61    %end
 &62    
 &63    %record(Stackfm)%map Address Items(%record(Stackfm)%name Par, Formal)
 &64       %record(Stackfm)%name W, X, Y, Z
 &65       %integer Rt, Format
 &66       %result == Procedure Items(Par) %if Formal_Form = Proc
 &67       %result == Arrayname Items(Par) %if Formal_Flags&Arrayname # 0
 &68    
 &69       X == Copy(Par);  Amap(X);  X_Prim = Integers;  X_Params == NIL
 &70    
 &71       Format = Par_Format
 &72       %if Formal_Type = Generals %start
 &73          Rt = Par_Type
 &74          %if Rt = Generals %start
 &75                            Advance(X, Integers, 0)
 &76             Y == Copy(X);  Advance(Y, Integers, Wordlength)
 &77             Z == Copy(X);  Advance(Z, Integers, Wordlength*2)
 &78          %else
 &79             Z == Literal(Type Code(Rt))
 &80             %if Rt = Strings %and X_Form = Direct %and Format = 1 %start {(*)}
 &81                Y == Copy(X);  Advance(Y, Integers, Wordlength)
 &82             %else
 &83                Y == Literal(Item Size(Format))
 &84             %finish
 &85          %finish
 &86                          Y_Prim    = Integers;  Z_Prim    = Integers
 &87          X_Params == Y;  Y_Params == Z;         Z_Params == NIL
 &88       %else %if Formal_Type = Strings %and Formal_Format = 1   {lhs string(*)name}
 &89          %if Format = 1 %and X_Form # Address %start           {rhs string(*)name}
 &90             Y == Copy(X);  Advance(Y, Integers, Wordlength)
 &91          %else
 &92             Y == Literal(Format)
 &93          %finish
 &94                          Y_Prim    = Integers
 &95          X_Params == Y;  Y_Params == NIL
 &96       %finish
 &97       %result == X
 &98    %end
?W unused
 &99    
 &100   %routine Pass Parameters(%record(Stackfm)%name V, %integername Extra,
 &101 +                          %integer BaseReg)
 &102      %integer Completed
 &103      %record(Stackfm)%name Par, Formal, Head, L
 &104      %record(Stackfm)%name Items, Rest, X, Y
 &105      %recordformat Rpfm(%record(Stackfm)%name P)
 &106      %record(Rpfm)%array Reginfo(R0:R3)
 &107      %ownrecord(Stackfm) Sp Mark                   {C-0087}
 &108   
 &109      Extra = 0
 &110      Head == V_Params;  %return %if Head == NIL  {no parameters}
 &111   
 &112      {Head is the start of a list of actual parameters in reverse (R-L) order}
 &113      {First, convert this into a forward list of integer, real & longreal items}
 &114   
 &115      Items == NIL
 &116      %while Head ## Nil %cycle
 &117         Par == Head;  Head == Head_Params
 &118         Stack Var(Par_Varno);  Formal == Stack;  Stack == Formal_Stack
 &119         %if Formal_Flags&Parameter # 0 %start       {procedure parameter}
 &120            X == Procedure Items(Par)
 &121         %else %if Formal_Flags&Arrayname # 0        {arrayname parameter}
 &122            X == Arrayname Items(Par)
 &123         %else %if Formal_Flags&Awanted # 0
 &124            %if Par_Oper = CONCx %start
 &125               Par == To Temp(Par, 256)
 &126            %else %if Formal_Type = Strings %and Par_Type # Strings
 &127               %if Iconst(Par) %then Fix Unitary String(Par) {-}%c
 &128 +                             %else Par == To Temp(Par, 2)
 &129            %else %if Par_Type = Strings %and Par_Bias = 1          {""}
 &130               Fix Unitary String(Par)
 &131            %else %if Par_Type = Sets
 &132               %if Par_Oper # 0 %start
 &133                  Loadup(Par)
 &134               %else %if Par_Members ## Nil
 &135                  Build Set(Par)
 &136               %finish
 &137            %finish
 &138            X == Address Items(Par, Formal)
 &139         %else
 &140            X == Copy(Par)
 &141            X_Prim    = Formal_Type
 &142            X_Params == NIL
 &143         %finish
 &144         Release and Drop Pair(Par, Formal)
 &145         Y == X;  Y == Y_Params %while Y_Params ## NIL
 &146         Y_Params == Items
 &147         Items == X
 &148      %repeat
 &149   
 &150      %routine Complete Register Processing
 &151         %integer R, N, Mask                           {C-0087}
 &152         %record(Stackfm)%name V
 &153         %return %if Completed # 0
 &154         Completed = 1
 &155         Monitor N(0, "+complete") %if Diag&MonOperand # 0
 &156   
 &157         {first, deal with the complex parameters}
 &158         %for R = R0, 1, R3 %cycle
 &159            V == Reginfo(R)_P
 &160            %continue %if V == NIL %or V == Sp Mark  {C-0087}
 &161            %if V_Oper # 0 %then Load(V, R) %else Simplify(V)
 &162         %repeat
 &163   
 &164         {Now, load up all the free registers}
 &165   
 &166         %for R = R0, 1, R3 %cycle
 &167            V == Reginfo(R)_P
 &168            %continue %if V == NIL %or V == Sp Mark       {C-0087}
 &169            Load(V, R) %if Activity(R) = 0 %and Ktimes(R) = 0
 &170         %repeat
 &171   
 &172         {Now, load up the inactive registers}
 &173   
 &174         %for R = R0, 1, R3 %cycle
 &175            V == Reginfo(R)_P
 &176            %continue %if V == NIL %or V == Sp Mark       {C-0087}
 &177            Load(V, R) %if Activity(R) = 0
 &178         %repeat
 &179   
 &180         {last scan to make sure}
 &181   
 &182         N = 0
 &183         %for R = R0, 1, R3 %cycle
 &184            V == Reginfo(R)_P
 &185            %continue %if V == NIL %or V == Sp Mark       {C-0087}
 &186            Load(V, R)
 &187            N = N+1        {one more active register}
 &188         %repeat
 &189   
 &190         {Beware - once the registers have been loaded they are released}
 &191         {If the HAZARD ALL in the CALL needs to use a register for     }
 &192         {Addressing it may well corrupt one of the parameter registers }
 &193         {Therefore do the hazarding here SCR???}
 &194   
 &195         %if Active Registers # N %start    {hazard pending registers}
 &196            %for R = R0, 1, R3 %cycle
 &197               V == Reginfo(R)_P
 &198               Hazard(R) %if V == NIL %or V == Sp Mark
 &199            %repeat
 &200            Hazard(R4);  Hazard(R5);  Hazard(R6);  Hazard(R7)
 &201            %if Active Registers # N %start
 &202               Hazard(R8);  Hazard(R11);  Hazard(R14)
 &203               %if Active Registers # N %start
 &204                  Hazard(F0);  Hazard(F1);  Hazard(F2);  Hazard(F3)
 &205                  %if Active Registers # N %start
 &206                     Hazard(F4);  Hazard(F5);  Hazard(F6);  Hazard(F7)
 &207                  %finish
 &208               %finish
 &209            %finish
 &210         %finish
 &211   
 &212         {now suck up any pushed values}             {C-0087}
 &213         Mask = 0                                    {C-0087}
 &214         N = 1                                       {C-0087}
 &215         %for R = R0, 1, R3 %cycle                   {C-0087}
 &216            %if Reginfo(R)_P == Sp Mark %start       {C-0087}
 &217               Extra = Extra-4                       {C-0087}
 &218               Mask = Mask ! N                       {C-0087}
 &219            %finish                                  {C-0087}
 &220            N = N<<1                                 {C-0087}
 &221         %repeat                                     {C-0087}
 &222         %if Mask # 0 %start                         {C-0087}
 &223            Plant4(LDM ! IA ! Write Back, Sp, Mask)  {C-0087}
 &224         %finish                                     {C-0087}
 &225   
 &226         {finally, get rid of everything}
 &227   
 &228         %for R = R0, 1, R3 %cycle
 &229            V == Reginfo(R)_P
 &230            %continue %if V == NIL %or V == Sp Mark
 &231            Release and Drop(V)
 &232         %repeat
 &233         Monitor N(0, "+complete") %if Diag&MonOperand # 0
 &234      %end
 &235   
 &236      %routine Push(%record(Stackfm)%name V, %integer Type)
 &237         %record(Stackfm) Spv = 0
 &238         Spv_Type = Type
 &239         Spv_Form = AutoD
 &240         Spv_Base = Sp
 &241         %if Type = Integers %start
 &242            Load(V, Any)
 &243            Plant2(STR, V_Base, SpV)
 &244         %else %if Type = Lreals
 &245            Load(V, AnyF)
 &246            Plant6(STFD, V_Base, SpV)
 &247            Extra = Extra+4           {twice as big as integers & reals}
 &248         %else %if Type = Reals
 &249            Load(V, AnyF)
 &250            Plant6(STFS, V_Base, SpV)
 &251         %else
 &252            Fail("Bad push type")
 &253         %finish
 &254         Extra = Extra+4
 &255         Release and Drop(V)
 &256      %end
 &257   
 &258   !{C-0087}
 &259   !   %routine Pop(%integer Reg)
 &260   !      {reg < 0 is a flag for loading |reg| and |reg|+1}
 &261   !      %record(Stackfm)%name Spv
 &262   !      %if Reg >= 0 %start
 &263   !         Spv == Literal(0)
 &264   !         Spv_Form = AutoI
 &265   !         Spv_Base = Sp
 &266   !         Load(Spv, Reg)
 &267   !         Release and Drop(Spv)
 &268   !      %else
 &269   !         Reg = -Reg                                        {SCR???}
 &270   !         Hazard(Reg);  Hazard(Reg+1)                       {SCR???}
 &271   !         Plant4(LDM ! IA ! Write Back, Sp, 3<<Actual(Reg)) {SCR???}
 &272   !         Extra = Extra-4
 &273   !      %finish
 &274   !      Extra = Extra-4
 &275   !   %end
 &276   !{C-0087}
 &277   
 &278      %routine Process(%record(Stackfm)%name V, %integer Rn)
 &279         %record(Stackfm)%name Next
 &280         %return %if V == NIL           {no more parameters}
 &281   !     Monitor(V, "+ Process ".TypeId(V_Prim)) %if Diag&MonOperand # 0
 &282         Next == V_Params
 &283   
 &284         %if Rn > R3 %start             {all registers dealt with}
 &285            Process(Next, R4)           {deal with all the rest}
 &286            Push(V, V_Prim)             {then push this one}
 &287         %else %if V_Prim = Integers
 &288            Reginfo(Rn)_P == V          {remember for later}
 &289            Process(Next, Rn+1)         {deal with the rest}
 &290         %else %if V_Prim = Reals
 &291            Simplify(V)                 {better be safe}
 &292            Load(V, AnyF) %if V_Type # Reals %and V_Type # Lreals
 &293            {This one can go into a register, but it may need to use [Sp]}
 &294            %if V_Form = Direct %start  {can go straight there}
 &295               V_Type = Integers
 &296               Reginfo(Rn)_P == V       {remember for later}
 &297               Process(Next, Rn+1)      {deal with the rest first}
 &298            %else                       {must go via [Sp]}
 &299               Process(Next, Rn+1)      {deal with the rest first}
 &300               Push(V, Reals)
 &301               Reginfo(Rn)_P == Sp Mark        {C-0087}
 &302   !           Complete register processing    {C-0087}
 &303   !           Pop(Rn)                         {C-0087}
 &304            %finish
 &305         %else %if V_Prim = Lreals
 &306            Simplify(V)                 {better be safe}
 &307            Load(V, AnyF) %if V_Type # Lreals
 &308            %if V_Form = Direct %start  {at least one bit can go in a register}
 &309               %if Rn = R3 %start       {second half must be pushed}
 &310                  Process(Next, Rn+2)   {deal with the rest first}
 &311                  Push(V, Lreals)       {push both}
 &312                  Reginfo(Rn)_P == Sp Mark     {C-0087}
 &313   !              Complete register processing {C-0087}
 &314   !              Pop(R3)                      {C-0087} {and bring back R3}
 &315               %else                    {second half fits into the next register}
 &316                  V_Type = Integers
 &317                  X == Copy(V);  Advance(X, Integers, 4)
 &318                  Reginfo(Rn+0)_P == V
 &319                  Reginfo(Rn+1)_P == X
 &320                  Process(Next, Rn+2)   {deal with the rest}
 &321               %finish
 &322            %else                       {must go via [Sp]}
 &323               Process(Next, Rn+2)      {deal with the rest first}
 &324               Push(V, Lreals)
 &325               %if Rn = R3 %start       {one into register}   {C-0087}
 &326                  Reginfo(Rn+0)_P == Sp Mark                  {C-0087}
 &327               %else                    {both into registers} {C-0087}
 &328                  Reginfo(Rn+0)_P == Sp Mark                  {C-0087}
 &329                  Reginfo(Rn+1)_P == Sp Mark                  {C-0087}
 &330               %finish                                        {C-0087}
 &331   !           Complete register processing   {C-0087}
 &332   !           %if Rn = R3 %start             {C-0087} {pop one  into registers}
 &333   !              Pop(Rn)                     {C-0087}
 &334   !           %else                          {C-0087} {pop both into registers}
 &335   !              Pop(-Rn)                    {C-0087}
 &336   !           %finish                        {C-0087}
 &337            %finish
 &338         %else
 &339            Fail("Bad process type")
 &340         %finish
 &341      %end
 &342   
 &343      Reginfo(R0)_P == NIL
 &344      Reginfo(R1)_P == NIL
 &345      Reginfo(R2)_P == NIL
 &346      Reginfo(R3)_P == NIL
 &347      Completed = 0
 &348      Process(Items, BaseReg)
 &349      Complete register processing
 &350   %end
?REST unused
?L unused
 &351   %endoffile
 3982  
 3983  %routine Array Index
 3984     %record(Stackfm)%name X, End
 3985     X == Stack                                   {the index}
 3986     Stack == Stack_Stack                         {the array}
 3987     End == Stack
 3988     End == End_Params %while End_Params ## Nil  {find the end}
 3989     End_Params == X
 3990       X_Params == Nil
 3991     Stack_Oper = Stack_Oper+1
 3992  %end
 3993  
 3994  %routine Array Access
 3995     %integer N, Lim, Flag, Type, Format, Xsize, Scale Needed = 0, MulOp
 3996     %record(Stackfm)%name X, All, Next, Mult, Scale
 3997  
 3998     %routine Set up MULT
 3999        Mult == Copy(X_Stack)                  {header}
 4000        Advance(Mult, Integers, 4)             {onto dope vector pointer}
 4001        Loadup(Mult)                       {pick up dope vector}
 4002        Mult_Disp = 20;  Mult_Form = Direct    {select multiplier 0}
 4003     %end
 4004  
 4005     Scale == NIL
 4006     X == Stack                               {index value}
 4007     Flag = X_Stack_Flags
 4008     MulOp = MULx
 4009     %if Flag&Defered = 0 %start
 4010        Scale Needed = 1 %if (X_Stack_Type = Strings %and X_Stack_Format = 1) %c
 4011+                        %or (X_Stack_Type = Records %and X_Stack_Format = 0)
 4012     %finish
 4013     Lim = 1
 4014     %if X_Stack_Oper # 0 %start              {final of multi-dimensional}
 4015        Array Index
 4016        Next == Stack_Params
 4017        All == Literal(0)
 4018        Lim = Stack_Oper;  Stack_Oper = 0
 4019        Set up MULT %if Flag&Arrayname # 0    {it's dynamic}
 4020        %for N = 1, 1, Lim %cycle
 4021           X == Next
 4022           Next == X_Params;  X_Params == Nil
 4023           %if N # 1 %start
 4024              %if Flag&Arrayname # 0 %start         {no constant dope vector}
 4025                 Operate(MulOp, All, Copy(Mult))
 4026                 Mult_Disp = Mult_Disp+12
 4027              %else
 4028                 Operate(MulOp, All, Literal(Stack_Adata_Bound(N-1)_Mult))
 4029              %finish
 4030           %finish
 4031           Operate(ADDx, All, X)
 4032        %repeat
 4033        Fail("Corrupt array index") %if Next ## Nil
 4034        X == All
 4035        %if Flag&Array = 0 %start
 4036           %if Scale Needed # 0 %start
 4037              Scale == Mult    {pointing at element size in the dope vector}
 4038           %else
 4039              Release and Drop(Mult)
 4040           %finish
 4041        %finish
 4042     %else                                    {Single dimensional}
 4043        Set up MULT %and Scale == Mult %if Scale Needed # 0
 4044        Stack == X_Stack
 4045     %finish
 4046     Type   = Stack_Type;  Stack_Type = Integers
 4047     Format = Stack_Format
 4048     Vmap(Stack, Integers) %if Flag&Arrayname # 0 {indirect through the header}
 4049     %if Flag&Defered # 0 %start        {namearray}
 4050        Xsize = Wordlength
 4051        Xsize = 2*Wordlength %if Type = Strings %and Format = 1
 4052     %else %if Scale ## NIL
 4053        Operate(MulOp, X, Scale)
 4054        Xsize = 1
 4055     %else
 4056        Xsize = Item Size(Format)
 4057     %finish
 4058     Stack_Flags = Stack_Flags ! Flag
 4059     Apply Index(Stack, X, Xsize)
 4060     %if Flag&Defered # 0 %start        {namearray}
 4061        Vmap(Stack, Type)
 4062     %else
 4063        Stack_Type = Type
 4064     %finish
 4065     Stack_Format = Format
 4066     Stack_Flags = Stack_Flags&( \(Static!Array!Arrayname) )
 4067     Monitor(Stack, "Array") %if Diag&MonOperand # 0
 4068  %end
 4069  
 4070  %routine Update Line(%integer This Line)
 4071     Fail("Stack")       %unless Stack == Nil
 4072     Fail("Registers")   %unless Active Registers = 0
 4073     Fail("Descriptors") %unless Using == Nil
 4074     Fail("Corrupt")     %if RegV(Any )_Base # Any %c
 4075+                        %or RegV(AnyF)_Base # AnyF
 4076  
 4077     %if This Line # Current Line %start
 4078        Current Line = This Line
 4079        Dir2(Dir Line, Current Line) %if Compiling Prim = 0
 4080     %finish
 4081  
 4082     %if Diag&MonLine # 0 %start
 4083        Select Output(Report)
 4084        Printstring("Line:");  Write(This Line, 1);  Newline
 4085        Select Output(Directives Out)
 4086     %finish
 4087  
 4088     Display Knowledge %if Diag&MonOpt # 0
 4089     Work Validity = Work Validity+1      {release work areas}
 4090     Value = Default Value                {restore default values}
 4091     
 4092  %end
 4093  
 4094  {Parameter and Format processing}
 4095  
 4096     %routine Terminate Block
 4097        %integer J, N, M
 4098        %record(Varfm)%name V
 4099        %if Amode < 0 %and Amode # -16 %start      {format - align alternatives}
 4100           Falign = Alt Align            {pass back nested alignment}
 4101           N = 0
 4102           %if Falign = \0 %start        {no alignment needed}
 4103              N = Frame Extra
 4104           %else %if Falign = \1         {halfword alignment}
 4105              N = Frame Extra&2
 4106           %finish
 4107           M = N
 4108           %if N # 0 %start              {can adjust}
 4109              %for J = Parms, 1, First Alt %cycle
 4110                 V == Var(J)
 4111                 V_Disp = V_Disp-N
 4112              %repeat
 4113              Max Frame = Max Frame-N
 4114              Frame     = Frame-N
 4115           %finish
 4116           Frame = Max Frame %if Max Frame > Frame
 4117           %if Amode = -2 %start                     {end of alternative}
 4118              Old Frame = Frame                      {pass it back}
 4119           %else                                     {end of complete format}
 4120              Avar_Disp = \Falign                    {***align***}
 4121              Frame = (Frame+(\Falign))&Falign
 4122              Avar_Format = Frame
 4123              Dir1(Dir Record Off)
 4124           %finish
 4125        %finish
 4126        Frame = Old Frame
 4127     %end
 4128  
 4129     %routine Copy Old Display
 4130        %integer T, J
 4131  
 4132        %routine Copy(%integer Flag, To)
 4133           %record(Stackfm)%name F, T
 4134           F == Literal(0)
 4135           %if Flag < 0 %start
 4136              F_Base = Local;
 4137           %else
 4138              F_Base = R8;  F_Form = AutoI;  Claim(F_Base)
 4139              Loadup(F)
 4140           %finish
 4141           T == Local Integer(To)
 4142           Plant2(STR, F_Base, T)
 4143           Release and Drop Pair(F, T)
 4144        %end
 4145  
 4146        T = Local Display
 4147        %for J = Danger Level, 1, Local-1 %cycle
 4148           Copy(0, T);  T = T+4
 4149        %repeat
 4150        Copy(-1, T)                  {special for FP}
 4151     %end
 4152  
 4153     %predicate Finish Params
 4154        %integer J,
 4155+                Mod = 0,       {002}
 4156+                Type, A, N
 4157        %record(Varfm)%name Ap, Fp, V
 4158        %record(Stackfm)%name S
 4159        Parameter Regs = 0
 4160        Parameter List = 0            {no longer in params or format}
 4161        Flush Diags %and %true %if Amode < 0           {end of format}
 4162        Parameter Frame = Frame
 4163  
 4164        %if Avar_Flags&Answer # 0 %and Avar_Flags&Defered = 0 %and
 4165+                   (Avar_Type = Strings %or Avar_Type = Records) %start
 4166           {allocate a result parameter}
 4167           Parameter Frame = Parameter Frame+4
 4168           String Result = 4;  Mod = Mod+4
 4169        %finish
 4170  
 4171        %if Amode = 0 %start         {remember parameter registers}
 4172           N = R0
 4173           A = 4
 4174           %while A < Parameter Frame %cycle
 4175              S == Local Integer(A)
 4176              Remember(N, S);  Drop(S)
 4177              Parameter Regs = Parameter Regs+1
 4178              A = A+4
 4179              %exit %if N = R3
 4180              N = N+1
 4181           %repeat
 4182        %finish
 4183  
 4184        Frame = -20                     {ready for local variables}
 4185        %if Varbase # Vars %start       {parameters given}
 4186           Avar_Extra = Parms           {first-1}
 4187           Avar_Area  = Parameter Frame {size of parameter part of frame}
 4188           %for J = Varbase+1, 1, Vars %cycle
 4189              Ap == Var(J)              {actual}
 4190              Parms = Parms-1
 4191              Fp == Var(Parms)          {formal}
 4192              Ap_Base = Local
 4193              Fp = Ap
 4194              Fp_Base = Sp              {WSP}
 4195              Fp_Form = AutoD
 4196              Fp_Disp = 0;  Ap_Disp = Ap_Disp+Mod
 4197              Fp_Flags = Fp_Flags!Known Ass
 4198              Fp_Flags = Fp_Flags!Awanted %if Ap_Form # Direct
 4199              Fp_Type = Integers %if Fp_Type = Bytes %or Fp_Type = Shorts
 4200              %if Ap_Flags&Awanted # 0 %and Amode = 0 %and Ap_Form # PROC %start
 4201                 {string/record value parameter}
 4202                 Ap_Flags = Ap_Flags-Awanted
 4203                 V == Var(Max Vars);  V = Ap
 4204                 Frame = Frame-Item Size(Ap_Format)
 4205                 V_Base = Local;  V_Disp = Frame
 4206                 Stack Var(Max Vars);  Stack Var(J)
 4207                 Type = Stack_Type;  Stack_Type = Integers;  Vmap(Stack, Type)
 4208                 Assign(Equals)
 4209                 Ap = V
 4210              %finish
 4211              Ap_Flags = Ap_Flags!Known Ass %if Ap_Flags&Parameter = 0
 4212           %repeat
 4213           Flush Diags
 4214        %finish
 4215        %true %if Amode # 0            {not a definition}
 4216        %if Danger Marker # 0 %start
 4217           Danger Level = Local %if Danger Level = No Danger
 4218        %finish
 4219        %if Danger Level # No Danger %start
 4220           Frame = Frame&(\3)-4*(Local-Danger Level+1)
 4221           Local Display = Frame
 4222           Attributes = Attributes ! Attr Local Display ! Attr Inherit
 4223        %finish
 4224        Copy old Display %if Local Display # 0      {copy the display}
 4225        %false                         {the body follows}
 4226     %end
 4227  
 4228     %integerfn Tag
 4229        %integer N
 4230        Readsymbol(N);  N = Pending<<8+N
 4231        Readsymbol(Pending)
 4232        %result = N
 4233     %end
 4234  
 4235     %routine Get String(%string(*)%name Text)
 4236        %integer J, Sym, Limit
 4237        Limit = Size of(Text)-1
 4238        Text = ""
 4239        %for J = Pending, -1,1 %cycle
 4240           Readsymbol(Sym)
 4241           Text = Text.Tostring(Sym) %if Length(Text) < Limit
 4242        %repeat
 4243        Readsymbol(Pending)
 4244     %end
 4245  
 4246     %predicate On IEEE
 4247        {differentiates between VAX & IEEE by means of the position}
 4248        {of the sign bit in floating-point numbers}
 4249        %integer Mone = -1
 4250        %longreal M = Mone
 4251        %byteinteger B = Byteinteger(Addr(M))
 4252        %true %if B = 0 %or B = 16_BF
 4253        %false
 4254     %end
 4255  
 4256     %routine Convert Format(%record(Stackfm)%name V, %integer Type)
 4257        %real Single
 4258        %integer A = V_Rhigh,
 4259+                B = V_Rlow,
 4260+                Fh, Fl, S, X
 4261        %unless A = 0 = B %or On IEEE %start
 4262           {first dismantle VAX form of FP numbers}
 4263           Fh = (A&2_1111111)<<16 ! (A>>16)         {top 23 bits of FP number}
 4264           FL = (B&16_FFFF)  <<16 ! (B>>16)         {low 32 bits of FP number}
 4265           X = (A>>7)                               {true exponent}
 4266           X = X&255-128
 4267           S = A>>15&1                              {sign bit}
 4268           %if Type = Lreals %start
 4269              X = (X+1023-1)&2_111 1111 1111        {NS exponent}
 4270              B = (Fh&7)<<29 ! (Fl>>3)
 4271              A = S<<31 + X<<20 + (Fh>>3)&16_000FFFFF
 4272           %else      {reals}
 4273              X = (X+127-1)&2_1111 1111
 4274              A = S<<31 + X<<23 + Fh
 4275              B = 0
 4276           %finish
 4277        %else %if Type = Reals                   {convert to short real}
 4278           Single = V_Rval
 4279           A = Integer(Addr(Single))
 4280           B = 0
 4281        %finish
 4282        V_Rhigh = A
 4283        V_Rlow  = B
 4284  %end
 4285  
 4286  %routine To Short Real(%record(Stackfm)%name V)
 4287     %integer X, Y, Exp, S
 4288     %return %if V_Rhigh = 0 = V_Rlow
 4289     %if On IEEE %start
 4290        Real(Addr(V_Rval)) = V_Rval
 4291     %else
 4292        X = V_RHigh;  S = X
 4293        Y = V_Rlow
 4294        Exp = ((X>>20)&2_111 1111 1111) - 1023 + 1   {true exponent}
 4295        Exp = Exp + 127 -1                           {short format}
 4296        X = (X&2_0000 0000 0000 1111 1111 1111 1111 1111)<<3
 4297        X = X ! (Y>>(32-3))                          {extra bits from mantissa}
 4298        X = X+1 %if Y&16_1000 0000 # 0               {round it}
 4299        %if X&16_0080 0000 # 0 %start                {need to normalise}
 4300           X = X>>1
 4301           Exp = Exp+1
 4302        %finish
 4303        X = X ! (Exp&255)<<23
 4304        X = X ! 16_8000 0000 %if S < 0
 4305        V_Rhigh = X
 4306        V_Rlow  = 0
 4307     %finish
 4308  %end
 4309  
 4310  %include "realcon.inc"
 &1     %longrealfn Real Constant
 &2        {Input an encoded real constant and convert to M/C representation}
 &3        %externallongrealfnspec Text to Floating %alias "3L___text_to_float" {-}%c
 &4   +                                      (%string(255) S, %integer Exp)
 &5        %integer Exp, J
 &6        %longreal Value
 &7        %string(255) S
 &8     
 &9        %on 1,4 %start
 &10          %if Event_Event = 1 %start
 &11             Fail("overflow while processing real constant")
 &12          %else %if Event_Event=4
 &13             Fail("error in real constant")
 &14          %else
 &15             Fail("Bad signal")
 &16          %finish
 &17       %finish
 &18    
 &19       S = "";  Exp = 0
 &20    
 &21       %for J = 1, 1, Tag %cycle        {gather the non-exponent part into S}
 &22          %if Pending = '@' %start      {exponent marker}
 &23             Readsymbol(Pending)        {skip the '@'}
 &24             Exp = Tag                  {only 16 bits}
 &25             Exp = Exp!16_FFFF8000 %if Exp&16_FFFF8000 # 0
 &26             %exit
 &27          %finish
 &28          S = S.Tostring(Pending)
 &29          Readsymbol(Pending)
 &30       %repeat
 &31       Value = Text to Floating(S, Exp)
 &32       %if Pending = 'U' %start               {unary minus following}
 &33          Value = -Value
 &34          Readsymbol(Pending)                 {skip the 'U'}
 &35       %finish
 &36       %result = Value
 &37    %end
 &38    %endoffile
 4311  
 4312  %integerfn Four Bytes
 4313     %integer A,B,C,D
 4314     A = Pending
 4315     Readsymbol(B)
 4316     Readsymbol(C)
 4317     Readsymbol(D)
 4318     Readsymbol(Pending)
 4319     %result = ((A<<8+B)<<8+C)<<8+D
 4320  %end
 4321  
 4322  %routine Input Integer Value(%integer Byte)
 4323     Constant Type = Integers
 4324     %if Byte = 0 %start
 4325        Value_Integer = Four Bytes
 4326     %else
 4327        Value_Integer = Pending;  Readsymbol(Pending)
 4328     %finish
 4329     %if Pending = 'U' %start
 4330        Value_Integer = -Value_Integer
 4331        Readsymbol(Pending)
 4332     %else %if Pending = '\'
 4333        Value_Integer = \Value_Integer
 4334        Readsymbol(Pending)
 4335     %finish
 4336     Stack Integer(Value_Integer) %unless Pending = 'A' {%or Pending = '$'}
 4337  %end
 4338  
 4339  %routine Input Real Value
 4340     Constant Type = Reals
 4341     Value_Real = Real Constant
 4342     %if Pending # 'A' %and Pending # '$' %start
 4343        Stack Integer(0)
 4344        %unless Value_Real = 0 %and (Pending = 'S' %or Pending = '?') %start
 4345               {preserve true zero}
 4346               {beware - a C-oid parameter 0.0 MUST retain}
 4347               {its real-ness otherwise the wrong amount}
 4348               {gets stacked}
 4349           Stack_Type = Lreals;  Stack_Rval = Value_Real
 4350           Convert Format(Stack, Lreals)
 4351        %finish
 4352     %finish
 4353  %end
 4354  
 4355  %routine Input String Value
 4356     %record(Stackfm)%name W
 4357     Constant Type = Strings
 4358     Get String(Value_String)
 4359     %return %if Pending = '$' %or Pending = 'A'
 4360     %if Length(Value_String) = 1 %start
 4361        Stack Integer(Charno(Value_String, 1))
 4362        Stack_Bias = -1
 4363     %else
 4364        W == Const String
 4365        W_Stack == Stack
 4366        Stack   == W
 4367     %finish
 4368  %end
 4369  
 4370  {Testing Predicates}
 4371  
 4372  %predicate InReg(%record(Stackfm)%name V)
 4373     %false %if V == Nil             %c
 4374+           %or V_Form    # Address  %c
 4375+           %or V_Disp    # 0        %c
 4376+           %or V_Base    = 0        %c
 4377+           %or V_Area    # 0        %c
 4378+           %or V_Oper    # 0        %c
 4379+           %or V_Index  ## Nil      %c
 4380+           %or V_Record ## Nil
 4381     %true
 4382  %end
 4383  
 4384  %predicate Floating(%record(Stackfm)%name V)
 4385     %true %if Reals <= V_Type <= Lreals %or V_Oper >= RNEGx
 4386     %false
 4387  %end
 4388  
 4389  %predicate Same(%record(Stackfm)%name A, B)
 4390     %true %if A == B
 4391     %false %if A == Nil %or B == Nil
 4392     %false %if A_Disp   # B_Disp    %or
 4393+               A_Base   # B_Base    %or
 4394+               A_Type   # B_Type    %or
 4395+               A_Form   # B_Form    %or
 4396+               A_Extra  # B_Extra   %or
 4397+               A_Area   # B_Area
 4398     %if A_Index ## Nil %start
 4399        %false %unless B_Index ## Nil                 %c
 4400+                 %and A_Xsize = B_Xsize              %c
 4401+                 %and Same(A_Index, B_Index)         %c
 4402+                 %and A_Index_Oper = B_Index_Oper    %c
 4403+                 %and Same(A_Index_Link, B_Index_Link)
 4404     %else
 4405        %false %if B_Index ## Nil
 4406     %finish
 4407     %if A_Record ## Nil %start
 4408        %false %unless B_Record ## Nil               %c
 4409+                 %and Same(A_Record, B_Record)      %c
 4410+                 %and A_Record_Oper = B_Record_Oper %c
 4411+                 %and Same(A_Record_Link, B_Record_Link)
 4412     %else
 4413        %false %if B_Record ## Nil
 4414     %finish
 4415     %true
 4416  %end
 4417  
 4418  %predicate Const(%record(Stackfm)%name V)
 4419     %false %if V_Form # Address %or
 4420+               V_Base # 0       %or
 4421+               V_Oper # 0       %or
 4422+               V_Index ## Nil   %or
 4423+               V_Record ## Nil  %or
 4424+               V_Area # 0
 4425     %true
 4426  %end
 4427  
 4428  %predicate Iconst(%record(Stackfm)%name V)
 4429     %false %if V == Nil         %c
 4430+           %or V_Form # Address %c
 4431+           %or V_Base # 0       %c
 4432+           %or V_Oper # 0       %c
 4433+           %or V_Index ## Nil   %c
 4434+           %or V_Record ## Nil  %c
 4435+           %or V_Type > Addrs   %c
 4436+           %or V_Area # 0
 4437     %true
 4438  %end
 4439  
 4440  %predicate Iconst Item(%record(Stackfm)%name V)
 4441     {Same as ICONST but ignores the OPER field}
 4442     %false %if V == Nil         %c
 4443+           %or V_Form # Address %c
 4444+           %or V_Base # 0       %c
 4445+           %or V_Index ## Nil   %c
 4446+           %or V_Record ## Nil  %c
 4447+           %or V_Type > Addrs   %c
 4448+           %or V_Area # 0
 4449     %true
 4450  %end
 4451  
 4452  %integerfn Power(%integer N)
 4453     %integer P, Mask
 4454     %result = -1 %if N > (  \( (-1)>>1 ) )>>1   {Beware x'4001' etc.}
 4455     Mask = 1
 4456     P = 0
 4457     %cycle
 4458        %result =  P %if Mask = N
 4459        %result = -1 %if Mask > N
 4460        Mask = Mask<<1
 4461        P = P+1
 4462     %repeat
 4463  %end
 4464  
 4465  %integerfn Item Size(%integer F)
 4466     %result = F %if F >= 0
 4467     %result = Var(-F)_Format
 4468  %end
 4469  
 4470  %record(Stackfm)%map Claim Work Area(%integer Bytes, Type)
 4471     %record(Stackfm)%name T
 4472     %record(Workfm)%name W, Best == NIL
 4473     %integer P
 4474     Fail("claim work area/1") %if Bytes <= 0
 4475     P = Work Base
 4476     %cycle
 4477        %if P = Last Work %start             {no suitable one available}
 4478           %if Best == NIL %start
 4479              Last Work = Last Work+1;  Best == Work Area(Last Work)
 4480              Frame = (Frame-Bytes)&(\3)
 4481              Best_Size = Bytes;  Best_Displacement = Frame
 4482           %finish
 4483           W == Best
 4484           %exit
 4485        %finish
 4486        P = P+1;  W == Work Area(P)
 4487        Monitor N(P, "try work") %if Diag&MonStack # 0
 4488        %if W_Validity < Work Validity %and W_Size >= Bytes %start
 4489           %exit %if W_Size = Bytes
 4490           Best == W %if Best == NIL %or Best_Size > W_Size
 4491        %finish
 4492     %repeat
 4493     W_Validity = Work Validity      {prevent its re-use}
 4494     Monitor N(W_Displacement, "temporary") %if Diag&MonStack # 0
 4495     T == Literal(W_Displacement)
 4496     T_Base = Local;  T_Type = Type;  T_Form = Direct;  T_Format = Bytes
 4497     %result == T
 4498  %end
 4499  
 4500  %routine Constant Bounds
 4501     Vub = Popped Value
 4502     Vlb = Popped Value
 4503  %end
 4504  
 4505  %routine Set CD(%integer Value, %integername CD)
 4506     CD = Value&x'3FFF' %if Value&x'C000' = 2<<14
 4507  %end
 4508  
 4509  %Predicate Alternate format(%integer Code)
 4510     %integer Attr = 0
 4511     %record(Varfm) Dummy
 4512     %if Code = 'A' %start           {Start of alternatives}
 4513        Assemble(Dummy, -2, Vars, Local, -1, Attr)
 4514        Alt Align = Alt Align&Falign
 4515     %else %if Code = 'C'            {Next alternative}
 4516        Max Frame = Frame %if Frame > Max Frame
 4517        Frame = Frame Base
 4518     %else %if Code = 'B'            {End of alternatives}
 4519        Frame = Max Frame %if Max Frame > Frame
 4520        Falign = Alt Align
 4521        %true
 4522     %else
 4523        Fail("Format ".ItoS(Code, 0))
 4524     %finish
 4525     %false
 4526  %end
 4527  
 4528  %routine Compile Begin
 4529     %integer Main Ep = 0
 4530     %record(Varfm) B
 4531     B = 0                           {Dummy heading}
 4532     B_Type = Generals
 4533     B_Disp = New Label
 4534     B_Base = None                   {show an internal routine}
 4535     %if Local # Base Local %start   {internal}
 4536        Stack Integer(B_Disp)
 4537        Stack_Flags = Stack_Flags!Nasty Proc %if Local >= Danger Level
 4538        Call(0)
 4539        Ostate = 0
 4540     %else
 4541        Ostate = External
 4542        External Id = "3L___main_program"
 4543        Entry Point = External No+1
 4544        Main Ep = 1
 4545     %finish
 4546     Internal Id = "block"
 4547     Internal Id = Alias %and Alias = "" %if Alias # ""
 4548     Assemble(B, 0, Vars, Local+1, 0, Attributes)
 4549  %end
 4550  
 4551  %routine Clear Vars(%integer Limit)
 4552     Fail("Too many objects") %if Limit >= Parms
 4553     %while Vars < Limit %cycle
 4554        Vars = Vars+1
 4555        Var(Vars) = 0
 4556     %repeat
 4557  %end
 4558  
 4559  {Var control}
 4560  
 4561     %routine DIR String(%integer Op, %string(*)%name S)
 4562        %integer L = Length(S), J
 4563        Dir1(Op) %if Op >= 0
 4564        Dir1(L)
 4565        Dir1(Charno(S, J)) %for J = 1, 1, L
 4566     %end
 4567  
 4568     %routine Dump External(%integer Code, %record(Varfm)%name V)
 4569        External No = External No+1
 4570        %if Code&1 = 0 %start                                {spec}
 4571           %if V_Form = Proc %then V_Area = Dir Xcall    %and V_Disp = External No %c
 4572+                            %else V_Area = -External No %and V_Disp = 0
 4573        %finish
 4574        Code = Code!4 %if Code&2 # 0 %and V_Flags&Prim Proc # 0 {not Prim proc}
 4575        DIR String(Dir Ext, External Id)
 4576        Dir2(Code, V_Disp)
 4577     %end
 4578  
 4579     %routine Plant Diag(%record(Diagfm)%name D)
 4580        %integer Disp, Type, Ind, Base, BType, PType
 4581        %record(Afm)%name Dv
 4582        %return %if D_X&64 # 0 %and D_Format&16_FFFF = 0
 4583        Disp = D_Var_Disp
 4584        Disp = D_Ext %if D_Ext # 0                       {external data}
 4585        Type = (D_X>>2)&15
 4586        %if Interface_Options&LL Vars # 0 %and Type # 14 %start
 4587           Dir String(Dir Diag, D_Id)
 4588           Dump Encoded(D_X)
 4589           Dump Encoded(D_Xtype)
 4590           Dump Encoded(D_Var_Disp)
 4591           Dump Encoded(D_Format&16_FFFF) %if D_X&64 # 0        {records}
 4592        %finish
 4593        %if DEBUG # 0 %start
 4594           Base = D_X&3
 4595           Ind  = D_X>>7
 4596           Btype = D_XType&15
 4597           PType = (D_XType>>4)&15
 4598           %if Type = 14 %start                     {Array}
 4599              Dir String(Dir DEBUG Array, D_Id)
 4600              Dv == D_Var_Adata
 4601              Dump Encoded(Dv_Bound(1)_Lower)
 4602              Dump Encoded(Dv_Bound(1)_Upper)
 4603              Dump Encoded(Dv_Total Size)
 4604              Dump Encoded(Btype)                   {base (element) type}
 4605              Dump Encoded(D_Format&16_FFFF)        {Pointer to format}
 4606           %else
 4607              %return %if Base # 1 %and Base # 2
 4608              Dir String(Dir DEBUG Var, D_Id)       {Variable identifier}
 4609              Dump Encoded(Type)                    {Primary type}
 4610              Dump Encoded(Ind)                     {Indirect bit - VAR}
 4611              Dump Encoded(Base)                    {Addressing base}
 4612              Dump Encoded(Btype)                   {Base type of pointer}
 4613              Dump Encoded(PType)                   {Type pointed at}
 4614              Dump Encoded(D_Var_Disp)              {Displacement from base}
 4615              Dump Encoded(D_Format&16_FFFF)        {Pointer to format}
 4616              Dump Encoded(Item Size(D_Var_Format)) {object size}
 4617           %finish
 4618        %finish
 4619     %end
 4620  
 4621     %routine Dump Diag(%integer Base, %record(Qfm)%name Q)
 4622        %record(Diagfm) D
 4623        %record(Diagfm)%name ND
 4624        %return %if Compiling Prim # 0
 4625        D_Link  == Diag List                      {here to prevent UNASS from VAX}
 4626        D_Id     = Internal Id
 4627        D_Xtype  = 0
 4628        D_Ext = 0
 4629        %if Base = Any %start
 4630           %return %if Parameter List = 0
 4631           Base = 0
 4632           D_Xtype = (Q_Dtype>>2)&15
 4633           Q_Dtype = 14<<2
 4634        %else %if Base = Local
 4635           Base = 1
 4636        %else %if Base = SB
 4637           Base = 2
 4638        %else %if Base < 0
 4639           D_Ext = -Base;  Base = 3
 4640        %else
 4641           Base = 0
 4642        %finish
 4643        %if Q == Nil %start
 4644           D_X = 0
 4645           D_Format = 0
 4646        %else
 4647           D_Format = Q_Dform
 4648           %if Q_Pointed ## Nil %start
 4649              D_Xtype = Q_Dtype>>2 ! (Q_Pointed_Dtype>>2&15)<<4
 4650              Q_Dtype = Q_Dtype ! 15<<2 ! Q_Pointed_Dtype&64    {escape}
 4651              D_Format = Q_Pointed_Dform
 4652           %finish
 4653           D_X = Q_Ind<<7 ! Q_Dtype ! Base
 4654        %finish
 4655        D_Var == DefV
 4656        %return %if D_Format = 0 %and D_X&64 # 0 {record(*)name}
 4657        %if Parameter List = 0 %start            {not in record or parameters}
 4658           Plant Diag(D)
 4659        %else
 4660           ND == NEW(Diagfm Type)
 4661  SYY:     ND = D
 4662           Diag List == ND                       {_Link set up above}
 4663        %finish
 4664     %end
?SYY unused
 4665  
 4666     %routine Flush Diags
 4667        %routine Flush(%record(Diagfm)%name D)
 4668           %return %if D == NIL
 4669           Flush(D_Link)
 4670           Plant Diag(D)
 4671           Dispose(D)
 4672        %end
 4673        {The list is currently backwards - reverse it to preserve order}
 4674        Flush(Diag List)
 4675        Diag List == NIL
 4676     %end
 4677  
 4678     %routine Define Var
 4679        %integer Decl, Tf, NewV, Area, External Mode
 4680        %integername At
 4681        %integer Spec, Oflags, N,
 4682+                Type,                     {external item type}
 4683+                Form,                     {external item form}
 4684+                Format                    {external item size or format}
 4685  
 4686        %record(Varfm)%name Fv
 4687        %record(Qfm) Q, Pq
 4688        %record(Stackfm)%name Vv
 4689  
 4690        %constbytearray Form Map(0:15) = 0,         {Unknown}
 4691+                                        Direct,    {integer}
 4692+                                        Indirect,  {integername}
 4693+                                        0(4),      {label/format/?/switch}
 4694+                                        Proc(4),   {rt/fn/map/pred}
 4695+                                        Direct,    {array}
 4696+                                        Direct,    {arrayname}
 4697+                                        Direct,    {namearray}
 4698+                                        Direct,    {namearrayname}
 4699+                                        0
 4700  
 4701        %routine Encode Type(%integer Type, Format, %record(Qfm)%name Q)
 4702           %switch T(-3:10)
 4703           %constshortarray DiagMap(-3:10) =
 4704+                      5<<2     {-3},  3<<2    {-2},  2<<2   {-1},
 4705+                         0      {0},
 4706+                      1<<2      {1},  4<<2     {2},  6<<2    {3},  7<<2!64 {4},
 4707+                      8<<2      {5}, 13<<2     {6}, 10<<2!64 {7}, 11<<2!64 {8},
 4708+                     12<<2      {9},  9<<2    {10}
 4709           %constbytearray TypeMap(-3:10) =
 4710+                      Lreals {-3},  Bytes  {-2}, Shorts {-1},
 4711+                     Generals {0},
 4712+                     Integers {1},   Reals  {2}, Strings {3},  Records {4},
 4713+                        Bytes {5},    Sets  {6},   Bytes {7},   Shorts {8},
 4714+                     Integers {9},   Bytes {10}
 4715           %constbytearray SizeMap(-3:10) =
 4716+                WordLength*2 {-3},          1  {-2},   2 {-1},
 4717+                WordLength*3  {0},
 4718+                 WordLength   {1}, WordLength*1 {2},   0  {3},  0   {4},
 4719+                          1   {5},    Set Size  {6},   1  {7},  2   {8},
 4720+                 WordLength   {9},          1  {10}
 4721           %constbytearray AlgnMap(-3:10) =
 4722+                           3 {-3},  0 {-2}, 1 {-1},
 4723+                           3  {0},
 4724+                           3  {1},  3  {2}, 0  {3}, 0  {4},
 4725+                           0  {5},  3  {6}, 0  {7}, 1  {8},
 4726+                           3  {9},  0 {10}
 4727  
 4728           %if Type = 1 %start {split integers}
 4729              %if Format = 2 %then Type = -2 {bytes} %else %c
 4730+             %if Format = 3 %then Type = -1 {short}
 4731           %else %if Type = 2  {split reals}
 4732              %if Format = 4 %then Type = -3 {longreal}
 4733           %finish
 4734  
 4735           Fail("Unknown type") %unless -3 <= Type <= 10
 4736  
 4737           Q_Type    = TypeMap(Type)
 4738           Q_Size    = SizeMap(Type);  DefV_Format = Q_Size
 4739           Q_Round   = AlgnMap(Type)
 4740           Q_Bias    = 0
 4741           Q_Dtype   = DiagMap(Type)
 4742           Q_Dform   = 0
 4743           Q_Format  = Format
 4744           Q_Diags   = 1                   {assume diags are sensible}
 4745           Q_Ind     = 0                   {assume not indirect}
 4746           Q_Pointed == Nil
 4747  
 4748           ->T(Type)
 4749  
 4750  T(0): {general}            Q_Diags = 0;  %return
 4751  
 4752  T(-3):{long}
 4753  T(1): {integer}
 4754  T(2): {real}
 4755  T(5): {boolean}            DefV_Flags = DefV_Flags ! Checkable
 4756  T(-1):{short}
 4757  T(-2):{byte}
 4758  T(10):{char}               %return
 4759  
 4760  T(3): {string}             Q_Size      = Format+1
 4761                             DefV_Format = Q_Size
 4762                             %return
 4763  
 4764  T(4): {record}             Fv == Var(Format)
 4765                             %if Format > Vars %start
 4766                                Clear Vars(Format)
 4767                                Interface_Formats = Interface_Formats+1
 4768                                Fv_Area = Interface_Formats
 4769                             %else
 4770                                Q_Size = Fv_Format
 4771                             %finish
 4772                             DefV_Format = -Format
 4773                             Q_Round     = Fv_Disp        {alignment required}
 4774                             Q_Dform     = Fv_Area        {diagnostic index}
 4775  
 4776  T(7): {byte enumerated}    Q_Dform = Var(Format)_Area;  %return
 4777  
 4778  T(8): {short enumerated}   Q_Dform = Var(Format)_Area;  %return
 4779  
 4780  T(9): {pointer}           DefV_Flags = DefV_Flags ! Checkable
 4781  T(6): {set}               %if Q ## Pq %start
 4782                                Encode Type(Q_Dim, Format, Pq)
 4783                                DefV_Format = SizeMap(Type) {restore it}
 4784                                Q_Pointed == Pq
 4785                             %else
 4786                                Q_Diags = 0
 4787                             %finish
 4788                             %if Type = 6 {sets} %start
 4789                                {beware of a checkable base type}
 4790                                DefV_Flags = DefV_Flags & (\Checkable)
 4791                             %finish
 4792                             %return
 4793  
 4794        %end {of encode type}
 4795  
 4796        NewV  = 1
 4797        Decl = Tag
 4798        %if Decl # 0 %start                {normal item}
 4799           NewV = 0 %if Decl <= Vars
 4800           DefV == Var(Decl);  Clear Vars(Decl)
 4801        %else                     {format item}
 4802           Parms = Parms-1
 4803           DefV == Var(Parms);  DefV = 0
 4804        %finish
 4805        Fail("Too many objects") %if Parms <= Vars
 4806  
 4807        Internal Id = ""
 4808        %while Pending # ',' %cycle
 4809           %if Length(Internal Id) # 127 %start
 4810              Internal Id = Internal Id.Tostring(Pending)
 4811           %finish
 4812           Readsymbol(Pending)
 4813        %repeat
 4814        Readsymbol(Pending)
 4815  
 4816        Tf     = Tag
 4817        Format = Tag
 4818        Ostate = Tag
 4819  
 4820        Q_Dim         = Ostate>>8
 4821        Spec          = Ostate&8
 4822        Oflags        = Ostate&16_F0
 4823        Ostate        = Ostate&7;  Ostate = External %if Ostate = Dynamic
 4824        Type          = Tf>>4&15
 4825        Form          = Tf&15
 4826  
 4827        %if Alias # "" %start
 4828           Ostate = External %if Ostate = System
 4829           External Id = Alias;  Alias = ""
 4830        %else %if Ostate = System
 4831           Ostate = External
 4832           External Id = "$".Internal Id
 4833        %else
 4834           External Id =     Internal Id
 4835        %finish
 4836        External Mode = Ostate
 4837  
 4838        %if Form = 0 %and Decl = 0 %start          {special for enumerated types}
 4839           Parms = Parms+1
 4840           Dump Diag(0, Nil)
 4841           %return
 4842        %finish
 4843  
 4844        Encode Type(Type, Format, Q);  Q_Diags = 0 %if Internal Id = ""
 4845  
 4846        DefV_Type = Q_Type
 4847        %if Oflags&16 # 0 %start                     {indirect}
 4848           DefV_Type = Integers;  DefV_Format = 4
 4849           Q_Ind = 1;  Q_Size = 4;  Q_Round = Alignment;  Q_Bias = 0
 4850           Form = 1
 4851        %finish
 4852        Q_Bias = 0 %if Form # 1
 4853        DefV_Flags = DefV_Flags!Checkable %if Oflags&32 # 0
 4854        Decl Size = Q_Size
 4855        DefV_Form = Form Map(Form)
 4856  
 4857        %if Form = 4 %start                                {recordformat}
 4858           DefV_Extra = Parms
 4859           Parameter Mode = -1;  Block Type = -1
 4860           %if DefV_Area = 0 %start
 4861              Interface_Formats   = Interface_Formats+1
 4862              DefV_Area = Interface_Formats  {diagnostic index}
 4863           %finish
 4864           %return
 4865        %else %if Form = 3                                 {label}
 4866           Set User Label(Decl)
 4867           %if Language Flags&Pascal Flag # 0 %start
 4868              Save Wsp %if Wsp Save = 0
 4869              DefV_Extra = Wsp Save
 4870           %finish
 4871        %else %if Form = 6                                 {switch}
 4872           DefV_Area     = Free Label-Vlb+1       {zero'th tag}
 4873           DefV_Disp     = Vlb                    {lower bound}
 4874           DefV_Extra    = Vub                    {upper bound}
 4875           N = Free Label+1
 4876           Free Label = N+Vub-Vlb
 4877           Constant Base = (Constant Base+3)&(\3) {align it}
 4878           Select Constant Area
 4879           DefV_Format   = Ca                     {address of vector}
 4880           Dump Word(Vub)                         {upper}
 4881           Dump Word(Vlb)                         {lower}
 4882           Dir3(Dir Swdef, N, Free Label)
 4883           Constant Base = Constant Base+4*(Vub-Vlb+1)
 4884           Select Code Area
 4885        %else %if 7 <= Form <= 10                          {rt, fn, map, pred}
 4886           Parameter Mode = 1
 4887           Block Type     = Spec                           {0=def, 8=spec}
 4888           %if 8 <= Form <= 9 %start                       {fn/map}
 4889              DefV_Flags = DefV_Flags!Answer
 4890              %if Form = 9 %start                          {map}
 4891                 DefV_Flags = DefV_Flags!Defered
 4892              %else %if DefV_Type <= Addrs                 {integral function}
 4893                 DefV_Type = Integers                      {all results integers}
 4894              %finish
 4895           %else %if Form = 10                             {predicate}
 4896              DefV_Flags = DefV_Flags!Pred Call
 4897           %finish
 4898           %if External Mode = OWN %start
 4899              External Mode = External
 4900              Ostate        = External
 4901              DefV_Flags = DefV_Flags ! Keep Local
 4902           %else %if External Mode >= Primrt
 4903              %if External Mode = PrimRt %start
 4904                 Defv_Flags = Defv_Flags!Primitive
 4905                 Defv_Prim  = Q_Dim
 4906              %else
 4907                 Defv_Flags = DefV_Flags!Prim Proc
 4908              %finish
 4909              External Mode = External
 4910              Ostate        = External
 4911           %finish
 4912           %if Parameter List > 0 %start        {proc variable}
 4913                                                {beware - a spec will follow}
 4914                                                {which must not corrupt flags}
 4915              Danger Marker = 1
 4916              Frame = (Frame+3)&(\3)            {keep word aligned}
 4917              DefV_Disp  = Frame
 4918              DefV_Base  = Local
 4919              DefV_Flags = DefV_Flags!Parameter
 4920              Frame = Frame + Word Length*2
 4921           %else %if Local >= Danger Level
 4922              DefV_Flags = DefV_Flags!Nasty Proc
 4923           %finish
 4924        %else
 4925           %if Form = 11 %or Form = 13 %start          {array or namearray}
 4926              Q_Diags = 0
 4927              %if Form = 13 %start                     {namearray}
 4928                 Decl Size  = Word Length
 4929                 Decl Size  = Word Length*2 %if Q_Type = Strings  %c
 4930+                                          %and Q_Size = 1      {string(*)%namearray}
 4931                 DefV_Flags = Defered
 4932                 Q_Round = Alignment
 4933              %finish
 4934              Q_Size  = 0                              {no space allocated here}
 4935           %else %if Form = 2                          {%name}
 4936              Q_Ind   = 1
 4937              Q_Round = Alignment
 4938              %if Q_Type # Generals %start
 4939                 Decl Size = Word Length
 4940                 Decl Size = Word Length*2 %if Q_Type = Strings  %c
 4941+                                         %and Q_Size = 1       {string(*)name}
 4942                 Q_Size = Decl Size
 4943              %finish
 4944           %else %if Form = 1                       {simple variable}
 4945              %if Parameter List > 0 %and (Q_Type = Strings   %c
 4946+                                      %or Q_Type = Records   %c
 4947+                                      %or Q_Type = Sets)    %start
 4948                 Q_Size = Word Length
 4949                 DefV_Flags = DefV_Flags!Awanted %if Oflags&16 = 0
 4950              %finish
 4951           %else                                    {arrayname or namearrayname}
 4952              Q_Diags = 0
 4953              Q_Round = Alignment
 4954              Q_Size  = Word Length*2
 4955              DefV_Flags = Defered %if Form = 14    {namearrayname}
 4956              DefV_Flags = DefV_Flags!Arrayname
 4957           %finish
 4958           %if External Mode = 0 %start                      {automatic}
 4959              DefV_Base = Local
 4960              %if Decl = 0 %start                            {record}
 4961                 Frame = (Frame+Q_Round)&(\Q_Round)
 4962                 Defv_Disp = Frame;  Frame = Frame+Q_Size
 4963              %else %if Parameter List > 0                   {parameters}
 4964                 Q_Round = 3 %if Q_Round < 3
 4965                 Q_Size  = 4 %if Q_Size  < 4
 4966                 Frame   = (Frame+3)&(\3)                    {keep parameters word aligned}
 4967                 DefV_Disp = Frame
 4968                 Frame = Frame+Q_Size
 4969              %else
 4970                 %if Q_Size > 256 %start                     {allocate dynamically}
 4971                    Q_Ind = 1
 4972                    Frame = Frame&(\3)-4                     {1 word slot}
 4973                    DefV_Disp = Frame;  DefV_Form = Indirect
 4974                    DefV_Flags = DefV_Flags&(\Checkable)
 4975                    N = (Q_Size+3)&(\3)                      {round up size}
 4976                    Attributes = Attributes!Attr Sp Unknown
 4977                    %if Unassigned # 0 %start                {set it unassigned}
 4978                       Attributes = Attributes!Attr Needs Gp
 4979                       Vv == Literal(N)
 4980                       Load(Vv, R4)
 4981                       Release and Drop(Vv)
 4982                       Prim(Dalloc)                          {alters SP}
 4983                    %else
 4984                       Vv == Local Integer(-N)
 4985                       Vv_Base = Sp;  Vv_Form = Address
 4986                       Load(Vv, Sp)                          {adjust Sp}
 4987                       Drop(Vv)
 4988                    %finish
 4989                    Vv == Local Integer(Frame)
 4990                    Plant2(STR, Sp, Vv)                      {initialise pointer}
 4991                    Release and Drop(Vv)
 4992  
 4993                    %if wsp save # 0 %start                  {done it, => wrong}
 4994                       save wsp                              {do it again}
 4995                    %finish                                  {quick hack}
 4996  
 4997                 %else
 4998                    Frame = Frame&(\Q_Round)-Q_Size
 4999                    DefV_Disp = Frame
 5000                 %finish
 5001              %finish
 5002              DefV_Flags = DefV_Flags!Known Ass %if Tf&256 # 0
 5003              Dump Diag(Local, Q) %if Q_Diags#0 %and Amode <= 0
 5004           %else                                             {own/external}
 5005              Ownextra = 0
 5006              %if Spec = 0 %start                            {definition}
 5007                 Init Flag = 0
 5008                 OwnType = Q_Type;  OwnForm = Form
 5009                 %if External Mode = Con %start              {const something}
 5010                    %if Form = 2  {constname}           %c
 5011+                   %or Form = 12 {constarrayname}      %c
 5012+                   %or Form = 14 {constnamearrayname}  %start
 5013                       DefV_Form = Direct
 5014                       Init Flag = -1
 5015                       %return
 5016                    %finish
 5017                    Constant Base = (Constant Base+3)&(\3)   {align it}
 5018                    Area = Constant Area;  At == Constant Base
 5019                    DefV_Area = Constant Area
 5020                    Q_Diags = 0
 5021                 %else                                       {ownish}
 5022                    Area = Own Area;       At == Own Base;       DefV_Base = Sb
 5023                    %if Form = 11 %or Form = 13 %start     {array or namearray}
 5024                       Own Array Base = (Own Array Base+3)&(\3)
 5025                       Area = Own Array Area;  At == Own Array Base
 5026                       Ostate = 255  {flag for INIT}
 5027                    %finish
 5028                 %finish
 5029                 Ownextra = 1 %if Ownform = 12 %or Ownform = 14 {..arrayname}
 5030                 Ownextra = 1 %if Owntype = Strings    %c
 5031+                            %and DefV_Format = 1      %c
 5032+                            %and (Ownform = 2 %or Ownform = 13)
 5033                                  {string(*) name & namearray}
 5034                 OwnType = Integers %and Q_Round = 3 %if OwnForm # 1  %c
 5035+                                                   %and OwnForm # 11
 5036                 At = (At+Q_Round)&(\Q_Round)
 5037                 DefV_Disp = At
 5038                 %if Form = 11 %or Form = 13 %start          {array or namearray}
 5039                    DefV_Flags = DefV_Flags!Arrayname
 5040                    N = DefV_Disp-Vlb*Decl Size      {back to A(0)}
 5041                    Own Base = (Own Base+3)&(\3)
 5042                    DefV_Base = SB;  DefV_Disp = Own Base;  DefV_Area = 0
 5043                    Select Own Area
 5044                    Dir4(Dir Header, Area>>8, N, 0);  Ca = Ca+8
 5045                    Select Code Area
 5046                    Value = Default Value
 5047                    Init Flag = 1
 5048                    {dummy dope-vector}
 5049                    DefV_Adata == New(A Type)
 5050  SYY:              DefV_Adata = 0
 5051                 %finish
 5052                 %if External Mode = External %start
 5053                    Dump External(2_01, DefV)
 5054                    DefV_Area = 0                            {beware prior %spec}
 5055                    DefV_Flags = DefV_Flags&(\XData Spec)    {  "      "     "  }
 5056                 %finish
 5057                 Dump Diag(DefV_Base, Q) %if Q_Diags # 0
 5058              %else                                          {external data spec}
 5059                 DefV_Flags = DefV_Flags ! XData Spec
 5060                 DefV_Flags = DefV_Flags!Arrayname %if Form = 11 %or Form = 13
 5061                 Dump External(2_00, DefV)
 5062              %finish
 5063           %finish
 5064        %finish
 5065        Alt Align = Alt Align&(\Q_Round)            {remember worst alignment}
 5066        Round = Q_Round
 5067        Dtype = Q_Dtype    {remember for arrays (dimension)}
 5068     %end
?SYY unused
 5069  
 5070     %routine Dump Text(%integer Max)
 5071        %integer J, Len
 5072        Len = Length(Value_String)
 5073        %if Max = 0 %start            {no upper limit}
 5074           Max = Len                  {use the actual length}
 5075        %else                {check the length}
 5076           Len = Max %and Warn(0, "String truncated") %if Len > Max
 5077        %finish
 5078        Dump Byte(Len)
 5079        %for J = 1, 1, Max %cycle
 5080           %if J > Len %then Dump Byte(0) %c
 5081+                      %else Dump Byte(Charno(Value_String, J))
 5082        %repeat
 5083     %end
 5084  
 5085     %routine Adump
 5086        %record(Stackfm) Rv
 5087        %integer J, Disp, Key
 5088        %if OwnType = Integers %or OwnType = Addrs %start
 5089           %if Stack == Nil %start                 {the easy case}
 5090              Dump Word(Value_Integer)
 5091           %else
 5092              %if Stack_Record ## NIL %start
 5093                 Fail("Adump/0")
 5094              %else
 5095                 Simplify(Stack)
 5096                 Disp = Stack_Disp
 5097                 Fail("Adump/1") %unless Stack_Record== Nil %and Stack_Index == Nil
 5098                 %if Stack_Form = Address %start
 5099                    %if Stack_Base = SB %start
 5100                       Key = 0
 5101                    %else %if Stack_Base = None
 5102                       %if Stack_Area = Constant Area %start
 5103                          Key = -1
 5104                       %else
 5105                          Key = -Stack_Area
 5106                          Fail("Adump/4") %if Key <= 0
 5107                       %finish
 5108                    %finish %else Fail("Adump/2")
 5109                    Dir3(Dir Init, Key, Disp)
 5110                 %finish %else Fail("Adump/3")
 5111              %finish
 5112              Ca = Ca+4
 5113              Pop Release and Drop
 5114           %finish
 5115        %else %if Owntype = Bytes %or Owntype = Booleans
 5116           Warn(0, "value truncated to 8 bits unsigned") %unless 0 <= Value_Integer <= 255
 5117           Dump Byte(Value_Integer)
 5118        %else %if OwnType = Shorts
 5119           Warn(0, "value truncated to 16 bits signed") %unless 16_FFFF 8000 <= Value_Integer <= 16_0000 7FFF
 5120           Dump Half(Value_Integer)
 5121        %else %if OwnType = Reals %or OwnType = Lreals
 5122           Rv_Rval = Value_Real;  Convert Format(Rv, Owntype) {BEWARE: = 1.3(12) etc}
 5123           Dump Word(Rv_Rhigh)
 5124           Dump Word(Rv_Rlow ) %if Owntype = Lreals
 5125        %else %if OwnType = Strings
 5126           Dump Text(Decl Size-1)
 5127        %else %if OwnType = Records %or Owntype = Sets
 5128           Dump Byte(0) %for J = 1, 1, Decl Size
 5129        %finish %else Fail("Init")
 5130        %while Ownextra > 0 %cycle
 5131           Dump Word(0)
 5132           Ownextra = Ownextra-1
 5133        %repeat
 5134     %end
 5135  
 5136     %routine Init(%integer N)
 5137        %if Stack ## Nil %and Iconst(Stack) %start
 5138           Value_Integer = Stack_Disp
 5139           Constant Type = Integers
 5140           Pop Release and Drop
 5141        %finish
 5142        %if Reals <= OwnType <= Lreals %start
 5143           Value_Real = Value_Integer %if Constant Type = Integers
 5144        %finish
 5145        %if Init Flag < 0 %start          {const?name}
 5146           DefV_Disp = Value_Integer
 5147        %else
 5148           %if Ostate = Con %then Select Constant Area  %else %c
 5149+          %if Ostate = 255 %then Select Own Array Area       %c
 5150+                           %else Select Own      Area
 5151           %while N > 0 %cycle
 5152              N = N-1;  Adump
 5153           %repeat
 5154           Select Code Area
 5155        %finish
 5156        Value = Default Value                {Restore the default values}
 5157        DefV_Flags = DefV_Flags!Known Ass
 5158     %end
 5159  
 5160     %routine Dimension(%integer Dim, N)
 5161        { %integerarray  A(1:5)  Base+Disp = Header (Direct) !Array!Static X=DV}
 5162        { %integerarray  B(1:N)  Base+Disp = Header (Direct) !Arrayname        }
 5163        { %integerarray _C(1:5)  Base+Disp = A(0)   (Direct) !Array        X=DV}
 5164        { %integerarrayname D    Base+Disp = Header (Direct) !Arrayname        }
 5165  
 5166        %integer X, Static Array = 0, J
 5167        %record(Varfm)%name V
 5168        %record(Afm) Dope
 5169        %record(Stackfm)%name B, Total, DopeVector, Zero, Header
 5170        %record(Stackfm)%name L1, L2, U1, U2, M1, M2
 5171        %record(Qfm) Q
 5172  
 5173        %predicate All Const
 5174           %record(Stackfm)%name P
 5175           %record(Boundfm)%name B
 5176           %integer J, N
 5177           P == Stack
 5178           N = Decl Size
 5179           %for J = Dim, -1, 1 %cycle
 5180              B == Dope_Bound(J)
 5181              %false %unless Iconst(P);  B_Upper = P_Disp;  P == P_Stack
 5182              %false %unless Iconst(P);  B_Lower = P_Disp;  P == P_Stack
 5183                                         B_Mult  = N
 5184              N  = B_Upper-B_Lower+1
 5185              Fail("Array inside-out") %if N < 0
 5186           %repeat
 5187           Dope_Total Size = N             {remember final bound}
 5188  
 5189           {A constant dope-vector}
 5190  
 5191           Dope_Base              = Local
 5192           Dope_Dimension         = Dim
 5193           Dope_Zero Displacement = 0
 5194           N = 0
 5195           %for J = 1, 1, Dim %cycle
 5196              B == Dope_Bound(J)
 5197              Dope_Zero Displacement = Dope_Zero Displacement*N-B_Lower
 5198              N = B_Mult
 5199              Dope_Total Size = Dope_Total Size*N
 5200           %repeat
 5201           Dope_Zero Displacement = Dope_Zero Displacement*N
 5202           Pop Release and Drop %for J = 1, 1, Dim*2
 5203           Static Array = 1
 5204           Constant Base = (Constant Base+Alignment)&Alignment Mask
 5205           Dope_Dv = Constant Base
 5206           %if Parameter List = 0 %start
 5207              Dope_Total Size = (Dope_Total Size+3)&(\3) {word align it}
 5208           %finish
 5209           Select Constant Area
 5210           Dump Word(Dim)
 5211           Dump Word(Dope_Total Size)
 5212           Dump Word(Dope_Zero Displacement)
 5213           %for J = 1, 1, Dim %cycle
 5214              B == Dope_Bound(J)
 5215              Dump Word(B_Lower)
 5216              Dump Word(B_Upper)
 5217              Dump Word(B_Mult)
 5218           %repeat
 5219           Select Code Area
 5220           %true
 5221        %end
 5222  
 5223        Attributes = Attributes ! Attr Sp Unknown
 5224  
 5225        {Create dope-vector}
 5226  
 5227        %if All Const %start                {constant dope-vector}
 5228           %return %if N = 0                {own dope vector}
 5229           %if Parameter List # 0 %start    {in format}
 5230             X = Parms+N
 5231             Frame = (Frame+Round)&(\Round)
 5232             %while N > 0 %cycle
 5233                N = N-1
 5234                X = X-1;  V == Var(X)
 5235                V_Disp = Frame+Dope_Zero Displacement
 5236                Frame = Frame+Dope_Total Size
 5237                V_Form = Direct
 5238                V_Flags = V_Flags!Array
 5239                V_Adata == New(A Type)
 5240  SYY:          V_Adata = Dope
 5241                %if Debug # 0 %start
 5242                   Q_Dform = 0
 5243                   Q_Dform = Var(-V_Format)_Area %if V_Format < 0
 5244                   Q_Pointed == NIL
 5245                   Q_Ind = 0
 5246                   Q_Dtype = Dtype
 5247                   DefV == V
 5248                   Dump Diag(Any, Q)
 5249                %finish
 5250             %repeat
 5251             %return
 5252           %finish
 5253           Zero       == Nil
 5254           Zero       == Literal(Dope_Zero Displacement) %c
 5255+                            %if Dope_Zero Displacement # 0
 5256           Total      == Literal(Dope_Total Size)
 5257           DopeVector == Literal(Dope_Dv)
 5258           DopeVector_Form = Address;  DopeVector_Area = Constant Area
 5259           Load(DopeVector, R3)
 5260           Load(Zero,  R2) %unless Zero == Nil
 5261           Load(Total, R1)
 5262        %else                                 {dynamic dope-vector}
 5263           %if Dim = 1 %start                 {special case fir 1 dimension}
 5264              U1 == Stack;  Stack == U1_Stack {upper bound}
 5265              L1 == Stack;  Stack == L1_Stack {lower bound}
 5266              M1 == Literal(Decl Size)
 5267              Load Trio(U1, R4, L1, R3, M1, R5)
 5268              Release and Drop Pair(L1, U1);  Release and Drop(M1)
 5269              Prim(Dynamic 1)
 5270           %else %if Dim = 2                  {special case for 2 dimensions}
 5271              U2 == Stack;  Stack == U2_Stack {upper bound}
 5272              L2 == Stack;  Stack == L2_Stack {lower bound}
 5273              M2 == Literal(Decl Size)
 5274              U1 == Stack;  Stack == U1_Stack {upper bound}
 5275              L1 == Stack;  Stack == L1_Stack {lower bound}
 5276              Load Pair(U1, R4, L1, R3)
 5277              Load Trio(U2, R7, L2, R6, M2, R8)
 5278              Load Pair(U1, R4, L1, R3)
 5279              Load Trio(U2, R7, L2, R6, M2, R8)
 5280              Release and Drop Pair(L1, U1)
 5281              Release and Drop Pair(L2, U2);  Release and Drop(M2)
 5282              Prim(Dynamic 2)
 5283           %else
 5284              X = Decl Size
 5285              %for J = 1,1,Dim %cycle
 5286                 Push Literal(X);  X = 0
 5287                 B == Stack; Stack == B_Stack;  Push(B);  Release and Drop(B)
 5288                 B == Stack; Stack == B_Stack;  Push(B);  Release and Drop(B)
 5289              %repeat
 5290              Push Literal(0)
 5291              Push Literal(0)
 5292              Push Literal(Dim)
 5293              Prim(Dynamic N)
 5294                              {returns with:  R1 = Total size (rounded)}
 5295                              {               R2 = Zero Displacement}
 5296                              {               R3 = Dope Vector address}
 5297           %finish
 5298           Total      == Register(R1)
 5299           Zero       == Register(R2)
 5300           DopeVector == Register(R3)
 5301        %finish
 5302  
 5303        {create the arrays}
 5304        {a head looks like:  <address of A0> <address of dope-vector> }
 5305        {                    ^               ^                        }
 5306        {                    V_Disp          V_Disp+4                 }
 5307  
 5308        Frame = Frame & (\3)
 5309        Header == Local Integer(Frame-Wordlength)
 5310        Load Address(Header, R4)         {end of headers}
 5311  
 5312        X = Vars-N
 5313        %while N > 0 %cycle
 5314           N = N-1
 5315           X = X+1;  V == Var(X)
 5316           Frame = Frame-2*Wordlength
 5317           V_Disp  = Frame                               {address of header}
 5318           V_Flags = V_Flags!Known Ass!ArrayName
 5319           V_Form  = Direct
 5320           Plant1(SUB, Sp, Sp, Just(R1))              {claim space}
 5321  {This can be improved by using R4 or Sp for the zero'th address}
 5322  {but it needs dope-vectors to be the other way round?}
 5323           %if Zero == NIL %start
 5324              Plant1(MOV,  0, R0, Just(Sp))
 5325           %else
 5326              Plant1(ADD, Sp, R0, Just(R2))
 5327           %finish
 5328           Plant4(STM ! Write Back, R4, 16_0009)   {STM_<R0,R3>, R0 = zero'th}
 5329        %repeat
 5330        Release and Drop(Total)
 5331        Release and Drop(Zero) %if Zero ## Nil
 5332        Release and Drop(DopeVector)
 5333        Release and Drop(Header)
 5334     %end
?SYY unused
 5335  
 5336     %routine Swop
 5337        %record(Stackfm)%name T
 5338        T           == Stack
 5339        Stack       == T_Stack
 5340        T_Stack     == Stack_Stack
 5341        Stack_Stack == T
 5342     %end
 5343  
 5344     %routine Define Range
 5345        %integer T
 5346        %record(Varfm)%name V
 5347        T = Tag;  V == Var(T);  Clear Vars(T)
 5348        Constant Bounds;  V_Disp = Vlb;  V_Extra = Vub;  V_Format = -1
 5349     %end
 5350  
 5351     %routine Test Range(%record(Stackfm)%name S, %record(Varfm)%name V)
 5352        %record(Stackfm)%name R, L, U, Low, High
 5353        %return %if Interface_Options&LL Range = 0
 5354        %if S_Type = Sets %start
 5355           Low  == Literal(V_Disp)
 5356           High == Literal(V_Extra)
 5357           Loadup(S) %if S_Oper # 0
 5358           Build Set(S) %if S_Members ## Nil
 5359           R == Copy(S);  Amap(R)
 5360           Load Trio(Low, R1, High, R2, R, R0)
 5361           Prim(Set Range)
 5362           Release and Drop Pair(Low, High);  Release and Drop(R)
 5363           %return
 5364        %finish
 5365  
 5366        %if Iconst(S) %start
 5367           %return %if V_Disp <= S_Disp <= V_Extra
 5368           Warn(1, "Range violation")
 5369        %finish
 5370  
 5371  
 5372        Loadup(S)
 5373        R == Copy(S)                      {so as not to destroy the register}
 5374        U == Literal(V_Extra)
 5375        %if V_Disp # 0 %start             {use dynamic range}
 5376           L == Literal(V_Disp)
 5377           Load Trio(R, R1, L, R2, U, R3)
 5378           Prim(Dynamic Range)
 5379           Release and Drop(L)
 5380        %else
 5381           Load Pair(R, R1, U, R3)
 5382           Prim(Check Range)
 5383        %finish
 5384        Release and Drop Pair(R, U)
 5385     %end
 5386  
 5387     %routine Duplicate
 5388        %record(Stackfm)%name V
 5389        V == Copy(Stack)
 5390        V_Stack == Stack
 5391        Stack == V
 5392     %end
 5393  
 5394     %routine Stack Work Variable
 5395        %integer T
 5396        %record(Varfm)%name V
 5397        T = Tag;  V == Var(T);  Clear Vars(T)
 5398        %if V_Base = None %start                     {a new one}
 5399           Frame = Frame&Alignment Mask-Wordlength
 5400           V_Type = Integers;  V_Form = Direct
 5401           V_Base = Local;     V_Disp = Frame
 5402           V_Flags = Known Ass
 5403        %finish
 5404        Stack Var(T)
 5405     %end
 5406  
 5407     %routine Claim With(%integer N)
 5408        %integer Format
 5409        %record(Withfm)%name W
 5410        W == NEW(Withfm Type)
 5411        W_Link == Withs;  Withs == W
 5412        W_Key = N
 5413        %if Stack_Index ## Nil %or Stack_Record ## Nil %c
 5414+                              %or Stack_Form # Direct %c
 5415+                              %or %not Locked(Stack_Base) %start
 5416           Format = Stack_Format
 5417           Amap(Stack); Stab(Stack)
 5418           Stack_Format = Format
 5419           Stack_Flags = Stack_Flags ! Stored With
 5420        %finish
 5421        W_Data = Stack_Data
 5422        Pop Release and Drop
 5423     %end
 5424  
 5425     %routine Release With(%integer N)
 5426        %record(Withfm) Base
 5427        %record(Withfm)%name W == Base, X
 5428        Base_Link == Withs
 5429        %while W_Link ## Nil %cycle
 5430           %if W_Link_Key = N %start
 5431              X == W_Link
 5432              W_Link == X_Link
 5433              Withs == Base_Link
 5434              Dispose(X)
 5435              %return
 5436           %finish
 5437           W == W_Link
 5438        %repeat
 5439        Fail("No use")
 5440     %end
 5441  
 5442     %routine Use With(%integer N)
 5443        %integer Format
 5444        %record(Withfm)%name W == Withs
 5445        %while W ## Nil %cycle
 5446           %if W_Key = N %start
 5447              Stack Integer(0)
 5448              Stack_Data = W_Data
 5449              %if Stack_Flags&Stored With # 0 %start
 5450                 Format = Stack_Format
 5451                 Vmap(Stack, Integers)
 5452                 Stack_Format = Format
 5453              %finish
 5454              %return
 5455           %finish
 5456           W == W_Link
 5457        %repeat
 5458        Fail("No use")
 5459     %end
 5460  
 5461     %routine Build Set(%record(Stackfm)%name S)
 5462        %record(Stackfm)%name W, Z, OldLink
 5463        %record(Memberfm)%name M, X
 5464        %recordformat Csetfm(%bytearray Set(0:31))     {32*8 = 256}
 5465        %record(Csetfm) C
 5466        %integer Dumped = 0, Marked = 0, In Work = 0, Low, High, Op, OldOper
 5467  
 5468        %routine Dump Set
 5469           %integer J
 5470           Dumped = 1
 5471           Constant Base = (Constant Base+3)&(\3)   {align it}
 5472           S_Type = Sets
 5473           S_Disp = Constant Base;  S_Form = Direct;  S_Area = Constant Area
 5474           Select Constant Area
 5475           Dump Byte(C_Set(J)) %for J = 0, 1, 31
 5476           Select Code Area
 5477        %end
 5478  
 5479        %routine Mark(%integer N)
 5480           %integer W
 5481           %unless 0 <= N <= 255 %start
 5482              Warn(1, "Set element out of range ".itos(N, 0))
 5483              %return
 5484           %finish
 5485           W = N>>3
 5486           C_Set(W) = C_Set(W) ! (1<<(N&7))
 5487           Marked = 1
 5488        %end
 5489  
 5490        Monitor(S, "Bset->") %if Diag&Monoperand # 0
 5491        OldLink == S_Link;  S_Link == NIL
 5492        OldOper  = S_Oper;  S_Oper = 0
 5493        C = 0
 5494        M == S_Members;  S_Members == Nil
 5495        S_Flags = S_Flags&(\Null Set)
 5496        %while M ## Nil %cycle
 5497          X == M;  M == M_Link
 5498          %if X_Const # 0 %start
 5499             High = X_A_Disp;  Drop(X_A)
 5500             %if X_B == Nil %start
 5501                Mark(High)
 5502             %else
 5503                Low = X_B_Disp;  Drop(X_B)
 5504                %while Low <= High %cycle
 5505                   Mark(Low);  Low = Low+1
 5506                %repeat
 5507             %finish
 5508          %else
 5509             %if In Work = 0 %start
 5510                W == Claim Work Area(Set Size, Sets)
 5511                %if Marked # 0 %start
 5512                   Dump Set %if Dumped = 0
 5513                   Set Assign(S, W)
 5514                   Release(S_Base)        {it's going to be copied over soon}
 5515                   Marked = 0
 5516                %else
 5517                   Z == Literal(0);  Z_Flags = Null Set
 5518                   Set Assign(Z, W)
 5519                   Release and Drop(Z)
 5520                %finish
 5521                S_Data = W_Data
 5522                Drop(W)
 5523                Dumped  = 1
 5524                In Work = 1
 5525             %finish
 5526             Amap(S);  Load Pair(S, R8, X_A, R1)
 5527             %if X_B == Nil %start
 5528                Op = Set Bit
 5529             %else
 5530                Load Trio(X_B, R0, S, R8, X_A, R1)
 5531                Release and Drop(X_B)
 5532                Op = Set Bits
 5533             %finish
 5534             Prim(Op)
 5535             Vmap(S, Sets);  S_Flags = S_Flags ! Work Set
 5536             Release and Drop(X_A)
 5537          %finish
 5538          Dispose(X)
 5539        %repeat
 5540        Dump Set %if Dumped = 0
 5541        S_Link == OldLink
 5542        S_Oper  = OldOper
 5543        Monitor(S, "Bset<-") %if Diag&MonOperand # 0
 5544     %end
 5545  
 5546     %routine Compile In(%integer Stack it)
 5547        %integer N
 5548        %record(Stackfm)%name V, Set, C
 5549        Set == Stack;  V == Set_Stack;  Stack == V_Stack
 5550        Build Set(Set) %if Set_Members ## Nil
 5551        Loadup(Set) %if Set_Oper # 0
 5552        %if Set_Flags&Null Set # 0 %start
 5553           %if Stackit # 0 %start
 5554              C == Literal(0)             {false}
 5555              C_Stack == Stack;  Stack == C
 5556           %else
 5557              Dump Word(16_E150 0000)     {CMPS _ R0, R0 = cc equal = false}
 5558           %finish
 5559           Release and Drop(Set);  Release and Drop(V)
 5560           %return
 5561        %finish
 5562        %if (Iconst(V) %and 0 <= V_Disp <= 255) %start
 5563           Advance(Set, Integers, (V_Disp>>5)<<2)
 5564           Operate(ANDx, Set, Literal(1<<(V_Disp&31)))
 5565           Test Zero(Set)
 5566        %else
 5567           Amap(Set)
 5568           Load Pair(V, R1, Set, R2)
 5569           Prim(SetIn)
 5570        %finish
 5571        Release and Drop Pair(Set, V)
 5572        Stack True or False(NE) %if Stackit # 0
 5573     %end
?N unused
 5574  
 5575     %routine Add Member(%integer N)
 5576        %record(Memberfm) Base
 5577        %record(Memberfm)%name M, P
 5578        %record(Stackfm)%name A, B == Nil
 5579        %integer Items = 0
 5580        A == Stack;  Stack == A_Stack
 5581        %if N # 0 %start
 5582           B == Stack;  Stack == B_Stack
 5583           %if Iconst(A) %and Iconst(B) %and A_Disp < B_Disp %start {empty}
 5584              Drop(A);  Drop(B);  %return
 5585           %finish
 5586        %finish
 5587        M == NEW(Memberfm Type)
 5588        M_A == A
 5589        M_B == B
 5590        Items = Stack_Members_Items %if Stack_Members ## NIL
 5591        %if Iconst(A) %and (B == Nil %or Iconst(B)) %start
 5592           M_Const = 1
 5593           M_Link == Stack_Members
 5594           Stack_Members == M
 5595        %else
 5596           M_Const = 0
 5597           Base_Link == Stack_Members
 5598           P == Base
 5599           P == P_Link %while P_Link ## Nil %and P_Link_Const # 0
 5600           M_Link == P_Link
 5601           P_Link == M
 5602           Stack_Members == Base_Link
 5603        %finish
 5604        Stack_Members_Items = Items+1
 5605        Stack_Flags = Stack_Flags&(\Null Set)
 5606     %end
 5607  
 5608     %routine Stack Data Size
 5609        %integer T, N
 5610        T = Pending;  Readsymbol(Pending)
 5611        %if T = 0 %start
 5612           T = Tag
 5613           N = Var(T)_Format
 5614           N = Var(-N)_Format %if N < 0 
 5615        %else
 5616           %if Undefined <= T <= Sets %then N = Type Size(T) %c
 5617+                                     %else N = 0
 5618           Fail("Unknown type") %if N = 0
 5619        %finish
 5620        Stack Integer(N)
 5621     %end
 5622  
 5623     %routine Test for NIL
 5624        %if Unassigned # 0 %start
 5625           Stack_Flags = Stack_Flags!Known Ass
 5626           Load(Stack, R1)
 5627           Prim(TestNil)      {tests NIL, Unassigned & Disposed}
 5628        %finish
 5629     %end
 5630  
 5631     %routine Set Variant Count(%integer N)
 5632        %record(stackfm)%name V == Copy(Stack), Count
 5633        Vmap(V, Shorts)
 5634        Count == Literal(N)
 5635        Simple(Count, V)
 5636        Release and Drop Pair(Count, V)
 5637     %end
 5638  
 5639  
 5640     %routine Test Variant Count(%integer N)
 5641        %record(Stackfm)%name V == Copy(Stack), Count
 5642        Count == Literal(N)
 5643        Vmap(V, Shorts)
 5644        Load Pair(V, R3, Count, R0)
 5645        Prim(Test Variant)
 5646        Release and Drop Pair(V, Count)
 5647     %end
 5648  
 5649     %routine Check not long NEW
 5650        %record(Stackfm)%name V == Copy(Stack)
 5651        Amap(V);  Vmap(V, Shorts)
 5652        Test Zero(V);  Invert = 0
 5653        Prim(Test NEW)
 5654        Release and Drop(V)
 5655     %end
 5656  
 5657     %routine Check Dynamic Bounds
 5658        %record(Stackfm)%name Lower, Upper
 5659        Upper == Stack;  Lower == Upper_Stack;  Stack == Lower_Stack
 5660        Load Trio(Stack, R1, Lower, R2, Upper, R3)
 5661        Prim(Dynamic Range)
 5662        Release and Drop Pair(Lower, Upper)
 5663     %end
 5664  
 5665     %routine Localise
 5666        {STACK Loc;  STACK size;  Stack Zero;  LOCALISE}
 5667        {Loc is a pointer to an area containing SIZE bytes}
 5668        {the area is copied into an anonymous local area and}
 5669        {Zero is the displacement of AREA(first) from Area(0)}
 5670        {i.e. Area(first) = Loc+Zero}
 5671        {Loc is updated to point to this local area}
 5672        %record(Stackfm)%name Loc, Size, Zero
 5673        Zero  == Stack
 5674        Size  == Zero_Stack
 5675        Loc   == Size_Stack
 5676        Stack == Loc_Stack
 5677        Forget Destination(Loc)
 5678        Amap(Loc)
 5679        Load Trio(Size, R0, Zero, R1, Loc, R2)
 5680        Prim(MakeLocal)
 5681        Attributes = Attributes ! Attr Sp Unknown
 5682        Release and Drop Pair(Size, Zero)
 5683        Release and Drop(Loc)
 5684     %end
 5685  
 5686     %routine End of Block
 5687        %if Local # Base Local %start          {not first (dummy) call}
 5688           %if Uncond Jump # Ca %and Avar_Type = Generals %and
 5689+                                    Avar_Flags&Prim Proc = 0 %start
 5690              Return(Routine)
 5691           %finish
 5692        %finish
 5693     %end
 5694  
 5695     %routine Process Include File
 5696        Get String(Include File)
 5697        Dir String(Dir Include, Include File)
 5698     %end
 5699  
 5700     %switch C(0:255)
 5701  
 5702        At = 0
 5703        Pending Auto = 0
 5704        Old Frame = Frame
 5705        %if Amode >= -1 %start                 {procedure definition, format start}
 5706           Frame = 0                           {ready for first field}
 5707           %if Amode >= 0 %start               {procedure def}
 5708              Frame = 4                        {ready for first parameter}
 5709              %if Avar_Flags&Xproc Spec # 0 %start  {previous external spec}
 5710                 Avar_Flags = Avar_Flags-Xproc Spec
 5711                 Avar_Disp  = 0
 5712              %finish
 5713              Avar_Disp = New Label %if Avar_Disp = 0 %and
 5714+                                   (Permrt # Ostate # External %or Amode = 0)
 5715              %if Amode = 0 %start               {entry to block}
 5716                 %if Local > Base Local + Max Nesting %start
 5717                    Fail("Subroutines nested too deeply")
 5718                 %finish
 5719                 Uncond Jump = -1;  Forget Everything
 5720                 Dir2(Dir Start Block, Avar_Disp);  Blocks = Blocks+1
 5721                 DIR String(-1, Internal Id)
 5722                 Fmark = Fmark+1;  Frame Use(Local) = Fmark
 5723                 %if DEBUG # 0 %start                                        {001}
 5724                    Dir3(Dir DEBUG Start Proc,                               {001}
 5725+                                  0,           {type}                       {001}
 5726+                                  Current Line {source})                    {001}
 5727                 %finish                                                     {001}
 5728              %finish
 5729              %if Ostate = External %start
 5730                 %if Amode # 0 %start            {external spec}
 5731                    Avar_Flags = Avar_Flags!Xproc Spec
 5732                    Dump External(2_10, Avar)
 5733                 %else            {external definition}
 5734                    Avar_Flags = Avar_Flags!Xproc Def
 5735                    N = 2_11
 5736                    N = 2_11 ! 1<<4 %if Avar_Flags&Keep Local # 0
 5737                    Dump External(N, Avar)
 5738                    Attributes = Attributes!Attr Xdef
 5739                    %if Avar_Flags&Prim Proc # 0 %start
 5740                       Attributes = Attributes!Attr Prim
 5741                    %finish
 5742                 %finish
 5743              %finish
 5744           %else
 5745              Dir2(Dir Record On, Avar_Area)
 5746           %finish
 5747        %finish
 5748  
 5749        Frame Extra = Frame
 5750        Frame       = (Frame+Alignment)&Alignment Mask
 5751        Frame Extra = Frame-Frame Extra
 5752        Frame Base  = Frame
 5753        MyMark    = Fmark
 5754        Max Frame = 0
 5755        Alt Align = \0
 5756        Pending Known Register = 0
 5757        Pending Auto = 0
 5758  
 5759        ->C('}') %if Code = 'H'                         {special for BEGIN}
 5760  
 5761        %cycle
 5762           Code = Pending;  Readsymbol(Pending);  ->C(Code)
 5763  
 5764  c('!'):  Operation(ORx);                                       %continue
 5765  c('"'):  Compare Double;                                       %continue
 5766  c('#'):  Jump Forward(Tag, NE);                                %continue
 5767  c('$'):  Define Var;                                           %continue
 5768  c('%'):  Operation(XORx);                                      %continue
 5769  c('&'):  Operation(ANDx);                                      %continue
 5770  c(''''): Input String Value;                                   %continue
 5771  c('('):  Jump Forward(Tag, LE);                                %continue
 5772  c(')'):  Jump Forward(Tag, GE);                                %continue
 5773  c('*'):  Operation(MULx);                                      %continue
 5774  c('+'):  Operation(ADDx);                                      %continue
 5775  c('-'):  Operation(SUBx);                                      %continue
 5776  c('.'):  Operation(CONCx);                                     %continue
 5777  c('/'):  Operation(DIVx);                                      %continue
 5778  c(':'):  Define Compiler Label(Tag);                           %continue
 5779  c(';'):  End of Block;                                 %exit
 5780  c('<'):  Jump Forward(Tag, LT);                                %continue
 5781  c('='):  Jump Forward(Tag, EQ);                                %continue
 5782  c('>'):  Jump Forward(Tag, GT);                                %continue
 5783  c('?'):  Compare Values;                                       %continue
 5784  c('@'):  Stack Var(Tag);                                       %continue
 5785  c('A'):  Init(Tag);                                            %continue
 5786  c('B'):  Jump Backward(Tag);                                   %continue
 5787  c('C'):  Compare Addresses;                                    %continue
 5788  c('D'):  Input Real Value;                                     %continue
 5789  c('E'):  Call(0);                                              %continue
 5790  c('F'):  Jump Forward(Tag, Always);                            %continue
 5791  c('G'):  Get String(Alias);                                    %continue
 5792  c('H'):  Compile Begin;                                        %continue
 5793  c('I'):  Select Input(Icode In2);  Readsymbol(Pending);        %continue
 5794  c('J'):  User Jump(Tag);                                       %continue
 5795  c('K'):  Return(False);                                        %continue
 5796  c('L'):  Define User Label(Tag);                               %continue
 5797  c('M'):  Return(Map);                                          %continue
 5798  c('N'):  Input Integer Value(0);                               %continue
 5799  c('O'):  Update Line(Tag);                                     %continue
 5800  c('P'):  Dump Byte(Popped Value&255);                              %continue
 5801  c('Q'):  Operation(RDIVx);                                     %continue
 5802  c('R'):  Return(Routine);                                      %continue
 5803  c('S'):  Assign(Equals);                                       %continue
 5804  c('T'):  Return(True);                                         %continue
 5805  c('U'):  Operate(NEGx, Stack, Nil);                            %continue
 5806  c('V'):  Return(Fn);                                           %continue
 5807  c('W'):  Switch Jump(Tag);                                     %continue
 5808  c('X'):  Operation(EXPx);                                      %continue
 5809  c('Z'):  Assign(EqualsEquals);                                 %continue
 5810  c('['):  Operation(LSHx);                                      %continue
 5811  c('\'):  Operate(NOTx, Stack, Nil);                            %continue
 5812  c(']'):  Operation(RSHx);                                      %continue
 5813  c('^'):  Stack_Format = -Tag;                                  %continue
 5814  c('_'):  Switch Label(Tag);                                    %continue
 5815  c('a'):  Array Access;                                         %continue
 5816  c('b'):  Constant Bounds;                                      %continue
 5817  c('c'):  Section = 1;  Get String(Section Id);         %exit
 5818  c('d'):  D = Tag;  N = Tag;  Dimension(D, N);                  %continue
 5819  c('e'):  Signal Event(Tag);                                    %continue
 5820  c('f'):  Compile For(Tag);                                     %continue
 5821  c('g'):  Test for NIL;                                         %continue
 5822  c('h'):  Special Call(Tag);                                    %continue
 5823  c('i'):  Array Index;                                          %continue
 5824  c('j'):  Assign(Jam);                                          %continue
 5825  c('k'):  Jump Forward(Tag, FF);                                %continue
 5826  c('l'):  Language Flags = Tag;                                 %continue
 5827  c('m'):  Do(Monitor Id, Monitor Ep, 0);                        %continue
 5828  c('n'):  Select(Tag);                                          %continue
 5829  c('o'):  Event Trap(Tag);                                      %continue
 5830  c('p'):  AssignParameter;                                      %continue
 5831  c('q'):  Process Include File;                                 %continue
 5832  c('r'):  Resolve(Tag);                                         %continue
 5833  c('s'):  To Store(Tag);                                        %continue
 5834  c('t'):  Jump Forward(Tag, TT);                                %continue
 5835  c('u'):  Aop;                                                  %continue
 5836  c('v'):  Operate(ABSx, Stack, Nil);                            %continue
 5837  c('w'):  Machine Code;  Forget Everything;                     %continue
 5838  c('x'):  Operation(REXPx);                                     %continue
 5839  c('y'):  Set CD(Tag, Diag);                                    %continue
 5840  c('z'):  Set CD(Tag, Control);                                 %continue
 5841  c('{'):  Assemble(DefV,
 5842+                   Blocktype,
 5843+                   Vars,
 5844+                   Local+1,
 5845+                   Parameter Mode, Attributes)
 5846              %continue
 5847  
 5848  c('}'):  %exit %if Finish Params
 5849           Do("3L___stack_check", Stack Check, 0) %if Interface_Options&LL Stack # 0
 5850           %continue
 5851  c('~'):  N = Pending;  Readsymbol(Pending)
 5852           %exit %if Alternate Format(N);                      %continue
 5853  
 5854     {************ Extra Items **************}
 5855  
 5856  c(128+'"'):  Unsigned = 10;  Stack Condition;                %continue
 5857  c(128+'?'):  Unsigned = 10;  Compare Values;                 %continue
 5858  c(128+','):  Max Frame = Frame %if Frame > Max Frame
 5859               Frame = Frame Base;                             %continue
 5860  c(128+'0'):  N = Tag;  {but no operation}                    %continue
 5861  c(128+'1'):  Add Member(0);                                  %continue
 5862  c(128+'2'):  Add Member(1);                                  %continue
 5863  c(128+'3'):  Set Variant Count(Tag);                         %continue
 5864  c(128+'4'):  Test Variant Count(Tag);                        %continue
 5865  c(128+'5'):  Check not long NEW;                             %continue
 5866  c(128+'6'):  Check Dynamic Bounds;                           %continue
 5867  
 5868  c(128+'/'):  Operation(UDIVx);                               %continue
 5869  c(128+'|'):  Operation(UREMx);                               %continue
 5870  c(128+'@'):  Decode(0, -1) %if Diag&Mon Code # 0
 5871               Current Line = Tag;                             %continue
 5872  c(128+'A'):  Amap(Stack);                                    %continue
 5873  c(128+'B'):  %if Pending = 't' %then Pending = '#' %c
 5874+                                %else Pending = '='
 5875               Test Zero(Stack);  Pop Release and Drop;        %continue
 5876  c(128+'C'):  Unsigned = 0;  Stack Condition;                 %continue
 5877  c(128+'D'):  Duplicate;                                      %continue
 5878  c(128+'E'):  Loadup(Stack) %unless Stack_Form = Address %c
 5879+                               %and Locked(Stack_Base)   %c
 5880+                               %and Stack_Record == Nil  %c
 5881+                               %and Stack_Index  == Nil;      %continue
 5882  c(128+'F'):  Stack_Format = -Tag;                            %continue
 5883  c(128+'I'):  Compile In(1);                                  %continue
 5884  c(128+'L'):  Localise;                                       %continue
 5885  c(128+'M'):  Operation(MODx);                                %continue
 5886  c(128+'N'):  Operation(REMx);                                %continue
 5887  C(128+'O'):  Apply Round(Stack);                             %continue
 5888  c(128+'P'):  Pop Release and Drop;                           %continue
 5889  c(128+'R'):  Define Range;                                   %continue
 5890  c(128+'S'):  Swop;                                           %continue
 5891  c(128+'T'):  Apply Trunc(Stack);                             %continue
 5892  c(128+'U'):  Use With(Tag);                                  %continue
 5893  c(128+'V'):  Vmap(Stack, Tag);                               %continue
 5894  c(128+'W'):  Stack Work Variable;                            %continue
 5895  C(128+'X'):  Loadup(Stack) %unless Stack_Type = Lreals;      %continue
 5896  c(128+'Z'):  Stack Integer(0);  Stack_Type = Sets
 5897                                  Stack_Flags = Null Set;      %continue
 5898  c(128+'['):  Claim With(Tag);                                %continue
 5899  c(128+']'):  Release With(Tag);                              %continue
 5900  c(128+'b'):  Input Integer Value(1);                         %continue
 5901  c(128+'c'):  General Compare;                                %continue
 5902  c(128+'e'):  N = Stack_Type ; Amap(Stack)
 5903               Loadup(Stack) %unless Stack_Form = Address %c
 5904+                               %and Locked(Stack_Base)   %c
 5905+                               %and Stack_Index  == Nil  %c
 5906+                               %and Stack_Record == Nil
 5907               Vmap(Stack, N);                                 %continue
 5908  c(128+'f'):  For Range == Var(Tag);                          %continue
 5909  c(128+'g'):  Call(1);                                        %continue
 5910  c(128+'i'):  Compile In(0);                                  %continue
 5911  C(128+'n'):  Apply Int(Stack);                               %continue
 5912  c(128+'m'):  General Move;                                   %continue
 5913  c(128+'o'):  Owntype = Tag;                                  %continue
 5914  c(128+'p'):  Fmap(Tag);                                      %continue
 5915  c(128+'r'):  Test Range(Stack, Var(Tag));                    %continue
 5916  c(128+'s'):  Set Size or Type(1, Stack);                     %continue
 5917  c(128+'t'):  Set Size or Type(2, Stack);                     %continue
 5918  c(128+'v'):  Compare Values;  Prim(Test Variant);            %continue
 5919  c(128+'w'):  Apply Intpt(Stack);                             %continue
 5920  c(128+'z'):  Stack Data Size;                                %continue
 5921  c(128+'{'):  Nn = 0
 5922               Assemble(AltV, -2, Vars, Local, -1, Nn)
 5923               Alt Align = Alt Align&Falign;                   %continue
 5924  c(128+'}'):  Frame = Max Frame %if Max Frame > Frame
 5925               Falign = Alt Align;                     %exit
 5926        %repeat
 5927  
 5928        Global Attributes = Global Attributes! (Attributes&Attr GLOBALS)
 5929        %if Amode&8 = 0 %start
 5930           Attributes = Attributes!Attr Inner Uses %if Frame Use(Local) # MyMark
 5931           %if DEBUG # 0 %start                                        {001}
 5932              Dir2(Dir DEBUG End Proc, Current Line {source})          {001}
 5933           %finish                                                     {001}
 5934           Dir1(Dir End Block)
 5935              Dump Encoded(Frame&Alignment Mask-Aframe)
 5936              Dump Encoded(Code Base)
 5937              Dump Encoded(Parameter Frame)
 5938              Dump Encoded(Parameter Regs)
 5939              Dump Encoded(Display Vector(Local))
 5940              Dump Encoded(Local Display)
 5941              Dump Encoded(Array Base)
 5942              Dump Encoded(Attributes)
 5943              Dump Encoded(Entry Mask)
 5944              Dump Encoded(Event Bits&16_FFFF)
 5945              Dump Encoded(Event Label)
 5946              Dump Encoded(Event Body)
 5947           Forget Everything
 5948           Avar_Flags = Avar_Flags!Open
 5949        %finish
 5950        Terminate Block
 5951        Display Vector(Local+1) = 0 %unless Local = Display Limit
 5952        Danger Level = No Danger %if Danger Level = Local
 5953        Pending Known Register = 0
 5954        Pending Auto = 0
 5955        Last Work = Work Base
 5956        %return
 5957  C(*): Fail("Code ".Itos(Code, 0))
 5958  %end
?PUSHADDRESS unused
?POTENTIALLYUNASSIGNED unused
?PROCID unused
?TOSHORTREAL unused
?CONST unused
 5959  
 5960  {Initialisation}
 5961  
 5962     Activity(Sp) = -1       {lock the stack pointer}
 5963     Activity(Fp) = -1       {lock the frame pointer}
 5964     Activity(Sb) = -1       {lock the static base}
 5965  
 5966     Compiling Prim = Interface_Prim
 5967     Unassigned     = Interface_Options&LL Assigned
 5968     Debug          = Interface_Options&LL Debug                    {001}
 5969     Own Base       = 16 %if Unassigned # 0
 5970  
 5971     Pvar(J)_P  == Nil %for J = 0, 1, Var Top
 5972  !0.9!   Ilabels(J) == NIL %for J = 0, 1, Max Label>>8
 5973  {0.9}   Ilabels(J)_Label == NIL %for J = 0, 1, Max Label>>8
 5974  
 5975     Select Input(Icode In);  Readsymbol(Pending)
 5976     Var(0) = 0
 5977     Default Value = 0            {*****make this unassigned later*****}
 5978     Value = Default Value
 5979  
 5980     %routine Initialise(%record(Stackfm)%name V, %integer Base, Form)
 5981        V = 0
 5982        V_Base  = Base
 5983        V_Type  = Integers
 5984        V_Form  = Form
 5985        V_Flags = Known Ass
 5986     %end
 5987  
 5988     Initialise(Ua Pat,   Sb, Direct)
 5989     Initialise(Zero,      0, Address)
 5990     Initialise(One,       0, Address);      One_Disp = 1
 5991     Initialise(SpV,      Sp, Address)
 5992  
 5993     %begin
 5994        %integer J
 5995        %record(Stackfm)%name R
 5996        %for J = R0, 1, AnyF %cycle
 5997           R == RegV(J)
 5998           R = 0
 5999           R_Base   = J
 6000           R_Type   = Integers
 6001           R_Form   = Address
 6002           R_Format = Wordlength
 6003           %if J >= F0 %start
 6004              R_Type   = Lreals
 6005              R_Format = Wordlength*2
 6006           %finish
 6007        %repeat
 6008     %end
 6009  
 6010     Knowing == Nil
 6011     Kasl    == Nil
 6012  
 6013     Select Output(Directives Out)
 6014     Parms = Max Vars             {leaving Var(Max Vars) free}
 6015     Constant Base = 0
 6016     Free Label    = 0
 6017     Section       = 0
 6018     Assemble(Var(0), -16, 0, Base Local, 0, J)           {Var(0) is a dummy}
 6019  
 6020     Dump Encoded(Entry Point)
 6021     Dump Encoded(Control)
 6022     Dump Encoded(Min SB)
 6023  
 6024     Interface_Ref Count         = Refs
 6025     Interface_Def Count         = Free Label
 6026     Interface_Block Count       = Blocks
 6027     Interface_External Count    = External No
 6028     Interface_Global Size       = Own Base
 6029     Interface_Global Array Size = Own Array Base
 6030     Interface_Constant Size     = Constant Base
 6031  
 6032     %begin                              {get rid of heap objects}
 6033        %routine Monitor(%string(255) Text)
 6034           Select Output(Report)
 6035           Printstring(Text);  Newline
 6036        %end
 6037  
 6038  
 6039        %record(Vvfm)%name V
 6040        Monitor("Dispose Vars") %if Diag&MonLine # 0
 6041        %while Var List ## NIL %cycle
 6042           V == Var List;  Var List == Var List_Link
 6043           DISPOSE(V)
 6044        %repeat
 6045  
 6046        %record(Knowfm)%name K
 6047        Monitor("Dispose Kasl") %if Diag&MonLine # 0
 6048        %while Kasl ## Nil %cycle
 6049           K == Kasl;  Kasl == Kasl_Link
 6050           DISPOSE(K)
 6051        %repeat
 6052  
 6053        %record(Ilabelfm)%name I
 6054        Monitor("Dispose Labels") %if Diag&MonLine # 0
 6055        %while Ilabel List ## NIL %cycle
 6056           I == Ilabel List;  Ilabel List == I_Link
 6057           DISPOSE(I)
 6058        %repeat
 6059  
 6060        %record(WorkVfm)%name W1, W2 == Work List_Link
 6061        Monitor("Dispose Work") %if Diag&MonLine # 0
 6062        %while W2 ## NIL %cycle
 6063           W1 == W2;  W2 == W2_Link
 6064           DISPOSE(W1)
 6065        %repeat
 6066        Monitor("Disposed") %if Diag&MonLine # 0
 6067     %end
 6068  
 6069  %end
?LASTAREA unused
?LASTDIR unused
?ICODE unused
?ENTERPROC unused
?REALINT unused
?NEXTCH unused
?READCH unused
?REALINTPT unused
?TESTREAL unused
?PRIMMUL unused
?TESTMOD unused
?NILTEST unused
?TRACELINE unused
?ASSTEST unused
?CAPTEST unused
?RTMONITOR unused
?AREF unused
?ROTX unused
?CALLIT unused
?INTERNAL unused
?LINK unused
?SL unused
?IP unused
?D68000 unused
 6070  
 6071  %endoffile

 8175 Statements compiled