         Edinburgh IMP77 Compiler - Version 8.4

    1  %externalroutinespec exit %alias "exit" (%integer rc)
    2  
    3  %externalroutine{spec} getblock {%alias "GETBLOCK_JSB"} (%integer len, %bytename base)
    4  %end
?BASE unused
?LEN unused
    5  %externalintegerfunction{spec} getlong {%alias "GETLONG_JSB"}
    6  %result=0
    7  %end
    8  %externalintegerfunction{spec} getword {%alias "GETWORD_JSB"}
    9  %result=0
   10  %end
   11  %externalroutine{spec} get(%integername n)
   12  %end
?N unused
   13  %externalroutine{spec} put(%integer n)
   14  %end
?N unused
   15  %externalroutine{spec} putword(%integer n)
   16  %end
?N unused
   17  %externalroutine{spec} putlong(%integer n)
   18  %end
?N unused
   19  %externalroutine{spec} putblock(%integer len, %bytename b)
   20  %end
?B unused
?LEN unused
   21  !   Computer Science VAX-11 Imp77 Compiler Second Pass
   22  !   23rd March 1981
   23  !
   24  !   Mods by MT June/July 1981:
   25  !
   26  !      - removed %const<>%name fault
   27  !      - fixed problem with definition of externals after %externally
   28  !        spec'ing them
   29  !      - fixed trouble with ++ and -- : introduction of VMAP
   30  !      - improved handling of 1-dimensional arrays (when checks off)
   31  !        - better code in general cases (eg. a(j+const); a(const) -> store ref)
   32  !        - generation of indexing (base[index]) in appropriate cases
   33  !      - fixed bug with moving records > 255 bytes from rec(*) name
   34  !      - generates error for untyped record moves
   35  !      - fixed general bug with moving/clearing records > 32K
   36  !      - improved record element access in several cases (save loading base)
   37  !        - ADDRESS, code in ASSEMBLE at C('n'): modified.
   38  !      - mod to LOAD to prefer 2-op operations where possible (but this
   39  !        should perhaps be removed when - if ever - remembering reg contents
   40  !        is implented, since useful information is deleted).
   41  !      - fixed (subtle) problem where turning off iovf checks after proc entry
   42  !        prevented suitable code to prevent traps on shifts, byte addition
   43  !        from being planted: control&16 # 0 => entry mask&iovf bit # 0
   44  !      - fixed bug where large quantities of data in gla made array header
   45  !        displacement wrong (var_header was %short, changed to %integer)
   46  !
   47  !   August 81:
   48  !
   49  !      - fixed %external..%array for cases where aref address not loaded
   50  !        into register - was losing XNO.....
   51  !
   52  !   September 81:
   53  !      - extended %prims - skipsymbol/ch etc added
   54  !
   55  !   October 81:
   56  !      - bug fix for  "real = \integer" etc
   57  !      - prims extended: PRINTSTRING parameter not now copied to
   58  !        work string (but may already be there!)
   59  !      - proper assignment checks on string resolution
   60  !      - added $_X:: CHARNO (as perm call)
   61  !      - %for loop mods
   62  !        - constant-bound loops
   63  !          - checks for validity at compile-time, no perm-call
   64  !        - doesn't call %any perm for no-check case!!
   65  !      - string length checking (AT LAST!!!!)
   66  !      - checks on size of constants in operations: eg "byte = 257" fails
   67  !        at compile time
   68  !      - put in compiler-specific perm routines GET, GET WORD, PUT etc
   69  !        as JSB-type, for compiler speed..
   70  !
   71  !   November 81:
   72  !      - outlawed other than plain %integer %for control variables!!
   73  !      - implemented READSYMBOL/CH for %strings
   74  !      - improved code for things like ++ (and effectively similar cases)
   75  !      - bug fixes for real constants, %for loops
   76  !
   77  !   December 81:
   78  !      - fixed external refs to ensure PIC code generated (avoid P3
   79  !        having to plug reference) ie @external never generated...
   80  !      - fixed (obscure) bug in taking the address of a label
   81  !      - generates error for ++, -- on string(*), record(*)
   82  !
   83  !   Known bugs:
   84  !
   85  !      * %external %routine %spec  x (%routine y)
   86  !          - corrupts next declaration
   87  !          (this is actually a pass 1 problem and should go away sometime)
   88  !      ? Meaning of %for j = x, 0, y %cycle ?
   89  !      ? Meaning of ADDR(arrayname), ADDR(array) ?
   90  !
   91  
   92  %control 0
   93  
   94  ! Include common constants, specs etc
   95  
   96  !!%include "control.imp"
   97  
   98  {%systemroutinespec exit %alias "exit" (%integer s)
   99  !%external %routine %spec  PUT (%integer n)
  100  !%external %routine %spec  PUT WORD (%integer n)
  101  !%external %routine %spec  PUT LONG (%integer n)
  102  !%external %routine %spec  PUT BLOCK (%integer n, %bytename b)
  103  %external %routine {%spec}  SELECT INPUT TANK (%integer n)
  104  %end
?N unused
  105  %external %routine {%spec}  SELECT OUTPUT TANK (%integer n)
  106  %end
?N unused
  107  !%external %routine %spec  GET (%integer %name ch)
  108  !%external %routine %spec  GET BLOCK (%integer len, %byte %name b)
  109  %external %routine %spec  PRINT RECORD (%integer len, %byte %name buff)
  110  %external %integer %function %spec  LOOK
  111  !%external %integer %function %spec  GETWORD
  112  !%external %integer %function %spec  GETLONG
  113  %external %integer %function %spec  TAG %alias "GETLONG";  ! For pass 2
  114  %external %string(63) %function %spec  ITOS (%integer n, p)
  115  
  116  ! streams
  117  %const %integer  report      = 0
  118  %const %integer  object file = 1
  119  %const %integer  listing     = 2
  120  %const %integer  diag stream = listing
  121  
  122  ! miscellaneous
  123  %const %integer  max ident = 31;        ! Length for external linkage
  124  %const %integer  fatal = 16_1000002C;   ! Error exit code to VMS
  125  
  126  
  127  ! external data (defined in driver)
  128  %external %string(6) %spec  version;    ! Compiler version string
  129  %external %integer %spec  command
  130  %external %integer %spec  control
  131  
  132  ! command bit meanings (set by command line)
  133  %const %integer  diag bit  = 8_00004
  134  %const %integer  line bit  = 8_00010
  135  %const %integer  log bit   = 8_00020
  136  %const %integer  time bit  = 8_01000
  137  %const %integer  entry bit = 8_02000
  138  %const %integer  init bit  = 8_04000
  139  %const %integer  pic bit   = 8_10000
  140  
  141  ! control bit meanings  (%control n, or set by driver (/check= etc))
  142  ! bit set => check on
  143  
  144  %const %integer  ass check  =   1;      ! unassigned checking
  145  %const %integer  str check  =   2;      ! string capacity checking
  146  %const %integer  for check  =   4;      ! %for checking
  147  %const %integer  arr check  =   8;      ! array bound checking
  148  %const %integer  ovf check  =  16;      ! integer overflow checking
  149  %const %integer  rec round  = 128;      ! rounding in records (turns it on)
  150  %const %integer  profiling  = 256;      ! call TRACE (line no) at bounds
  151  
  152  ! object file commands  Pass2 => Pass3
  153  
  154  %const %integer  obj extern    = 1;     ! insert external entry
  155  %const %integer  obj code      = 2;     ! code block
  156  %const %integer  obj gla       = 3;     ! gla  block
  157  %const %integer  obj pdef      = 4;     ! external proc definition
  158  %const %integer  obj pspec     = 5;     ! external proc specification
  159  %const %integer  obj ddef      = 6;     ! external data definition
  160  %const %integer  obj dspec     = 7;     ! external data specification
  161  %const %integer  obj reloc     = 8;     ! relocate gla
  162  %const %integer  obj set       = 9;     ! set gla to tag address
  163  %const %integer  obj header    = 10;    ! start of procedure
  164  %const %integer  obj call      = 11;    ! procedure call
  165  %const %integer  obj jump      = 12;    ! jump
  166  %const %integer  obj prim spec = 13;    ! prim definition
  167  %const %integer  obj end       = 14;    ! end of object file
  168  %const %integer  obj line      = 15;    ! line number
  169  %const %integer  obj term      = 16;    ! end of block
  170  %const %integer  obj diag p    = 17;    ! diags for proc header
  171  %const %integer  obj diag v    = 18;    ! diags for variable
  172  %const %integer  obj weak      = 19
  173  %const %integer  obj b lab     = 20;    ! bxxb in m/code
  174  %const %integer  obj w lab     = 21;    ! bxxw in m/code
  175  %const %integer  obj glam      = 22;    ! initialise n items in GLA
  176  %const %integer  obj modd      = 23;    ! modify displacement
  177  %const %integer  obj prim ref  = 24;    ! call to prim
  178  %const %integer  obj ext ref   = 25;    ! call to external procedure
  179  %const %integer  last obj code = 25
  180  
  181  ! directive file commands  Pass2 => Pass3
  182  
  183  %const %integer  dir used      = 1;     ! external used
  184  %const %integer  dir ldef      = 2;     ! label definition
  185  %const %integer  dir pref      = 3;     ! procedure reference
  186  %const %integer  dir cref      = 4;     ! conditional label reference
  187  %const %integer  dir uref      = 5;     ! unconditional label reference
  188  %const %integer  dir end       = 6;     ! end of procedure
  189  %const %integer  dir sizes     = 7;     ! end of directives+sizes
  190  %const %integer  dir x end     = 8;     ! end of external entry
  191  %const %integer  dir header    = 9;     ! start of procedure
  192  %const %integer  dir entry     = 10;    ! define entry label
  193  %const %integer  last dir code = 10
  194  
  195  !!%end %of %file
  196  
  197  %external %routine  PASS2 (%integer icode, object, directives)
  198     !
  199     ! Aborts:   (* means solution %might be to turn up a size constant)
  200     !
  201     !     0  unimplemented feature
  202     !     1  Operand:      bad base register for operand
  203     !     2  Operand:      operation still pending on operand
  204     !     3  Release:      register not claimed
  205     !     4  Hazard:       bad operand form
  206     !     5  Hazard:       register activity inconsistent
  207     !  *  6  Descriptor:   no free descriptors
  208     !  *  7  Descriptor:   no free descriptor pointers
  209     !  *  8  Descriptor:   stack overflow
  210     !     9  Drop:         descriptor not on using list
  211     !    10  Set both:     stack underflow
  212     !    11  Pop lhs:      stack underflow
  213     !    12  Pop drop:     stack underflow
  214     !    13  Operand:      invalid operand form
  215     !  * 14  Define var:   var table overflow
  216     !    15  Amap:         cannot take address of object
  217     !  * 16  New label:    no labels left
  218     !    17  Operate:      stack empty on unary operation
  219     !    18  Operate:      stack < 2 deep on binary
  220     !    19  Cop:          unexpected operation
  221     !    20  For:          non-integer control variable
  222     !    21  Assemble:     bad code item
  223     !    22  Assemble:     array in record bounds inside-out
  224     !    23  Line bound:   stack not empty
  225     !    24  Line bound:   using list not empty
  226     !    25  Line bound:   regs still active
  227     !  * 26  Assemble:     var table overflow
  228     !    27  Operand:      cannot perform indexing
  229     !    28  Operand:      AP/FP/PC as register operand
  230     !  * 29  Work string:  too many temp areas required
  231     !    30  Load:         2nd reg for >> or REM is locked
  232     !    31  Hazard:       index reg usage inconsistent (hazarding index reg)
  233     !    32  Load:         cannot perform real op
  234     !    33  Load:         cannot perform integer op
  235     !    34  Set cc:       bad comparator specified
  236     !    35  Scale index:  invalid length for indexed addressing
  237     !    36  Assemble:     bad symbol after '~' (ie. not {A, B, C})
  238     !    37  Load:         bad register
  239     !    38  Hazard:       index register use inconsistent
  240     !    39  Line bound:   index reg still active
  241     !    40  Claim:        bad register for index
  242     !    41  Release:      " "  " "  "  "  "  "
  243     !    42  Release:      released index reg is locked
  244     !    43  Release:      released index reg but no indexing active
  245     !    44  Release:      released index reg not claimed as index
  246     !    45  Record sel:   invalid form for base record
  247     !    46  Address:      bad form for indexed operand
  248     !    47  Call:         operation pending on READSYMBOL parameter
  249     !    48  Set modulus:  constant not %longreal %or %integer
  250     !
  251     !================================================================
  252     !
  253     ! %diagnose significance
  254     !
  255     !   diag bit:      monitors:
  256     !            1  =  stack procedures
  257     !            2  =  load
  258     !            4  =  hazard/claim/release
  259     !            8  =  assign/array ref
  260     !           16  =  call/push
  261     !           32  =  address
  262     !           64  =  amap/vmap
  263     !          128  =  put code/operand
  264     !          256  =  operate
  265     !
  266     !         2048  =  I-code main symbols
  267     !         4096  =  stack dump on MONITOR
  268     !         8192  =  %monitor on MONITOR
  269     !
  270  
  271     %own %integer  original control
  272                    original control = control
  273  
  274     %own   %integer  diag = 0
  275  
  276     %const %integer  mainrt = 1, mainfn = 2
  277  
  278     ! Size constants +++++++++++++++++++++  associated aborts
  279  
  280     %const %integer  max vars   = 2000;   ! 14, 26   : var table size
  281     %const %integer  max labels = 120;    ! 16       : # active internal labs
  282     %const %integer  max depth  = 16;     ! 8        : depth of descr stack
  283     %const %integer  max stack  = 25;     ! 6, 7     : # in-use descriptors
  284     %const %integer  max work   = 12;     ! 29       : # active work strings
  285  
  286  !register definition
  287  
  288     %const %integer  r0      = 1;             !used in prim
  289     %const %integer  r1      = 2;             !used in prim
  290     %const %integer  r2      = 3;             !used in prim
  291     %const %integer  r3      = 4;             !used in prim
  292     %const %integer  r4      = 5;             !used in prim
  293     %const %integer  r5      = 6;             !used in prim
  294     %const %integer  r6      = 7;             !base register (level 1)
  295     %const %integer  r7      = 8;             !base register (level 2)
  296     %const %integer  r8      = 9;             !base register (level 3)
  297     %const %integer  r9      = 10;            !base register (level 4)
  298     %const %integer  r10     = 11
  299     %const %integer  gla     = 12;            !r11 = gla base
  300     %const %integer  ap      = 13;            !argument pointer (r12)
  301     %const %integer  fp      = 14;            !frame pointer (lnb)
  302     %const %integer  sp      = 15;            !stack pointer (r14)
  303     %const %integer  pc      = 16;            !program counter (r15)
  304     %const %integer  any     = 17;            !any general register
  305  
  306     %const %integer  fpr0    = 18
  307     %const %integer  fpr2    = 19
  308     %const %integer  fpr4    = 20
  309  
  310     %const %integer  pending = 22;            !spec pending
  311  
  312     %const %short %array  actual reg (0 : 20) =
  313+       -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
  314+       13, 14, 15, 0, 0, 2, 4
  315  
  316     %const %short %array  reg mask (0 : 20) =
  317+       0, 0, 0, 4, 8, 16_10, 16_20, 16_40, 16_80,
  318+       16_100, 16_200, 16_400, 16_800, 0, 0, 0, 0, 0, 0,
  319+       16_c, 16_30
  320  
  321     %const %integer  iovf bit = 16_4000;! Set in entry mask to enable IOVF trap
  322  
  323     %const %byte %array  base reg (-1 : 6) =
  324+       ap, ap, r6, r7, r8, r9, ap, ap
  325  
  326     !types and precisions
  327  
  328     %const %integer integers = 16_10
  329     %const %integer byte     = 2;     !unsigned byte
  330     %const %integer short    = 1;     !signed   halfword
  331     %const %integer long     = 5;     !longinteger
  332     %const %integer reals    = 16_23, reall = 16_24, real bit = 16_20
  333     %const %integer strings  = 16_40, in work = 4
  334     %const %integer records  = 16_80
  335  
  336     %const %integer null string = 24;     !disp of null string in gla
  337  
  338     !data forms
  339  
  340     %const %integer jump   = 0;         !cond code for jump
  341     %const %integer switch = 6
  342     %const %integer recfm  = 4
  343  
  344     %const %integer proc bit      = 16
  345     %const %integer array bit     = 32
  346     %const %integer arrayname bit = 64
  347     %const %integer indirect bit  = 128
  348  
  349     %const %integer constant  = 0
  350     %const %integer  v in r   = 1;   !variable in register
  351     %const %integer  v in s   = 2;   !variable in store
  352     %const %integer av in s   = 3;   !address of variable in store
  353     %const %integer  a in s   = 4;   !address in store (indirect)
  354     %const %integer rec mod   = 3;   ! x in rec = x in s + rec mod
  355     %const %integer  v in rec = 5;   !variable in record (+extra)
  356     %const %integer av in rec = 6;   !address of variable in record (+extra)
  357     %const %integer  a in rec = 7;   !address in record (indirect+extra)
  358  
  359     !form flags
  360  
  361     %const %integer indexed = 1,    { base[index] }
  362+                    x defer = 2,    {(with indexed) @base[index]  - arrayname}
  363+                    auto i  = 4,
  364+                    auto d  = 8
  365  
  366  
  367     %const %byte %array  fmap (0 : 15) =
  368+       0,    vins,   ains+indirect bit,
  369+      {null  scalar  name}
  370+       15, recfm, 0, switch,
  371+      {3    4    5     6}
  372+       procbit, vinr+procbit, vins+procbit, procbit,
  373+      {routine  function      map           pred}
  374+       vins+arraybit,   vins+arrayname bit,
  375+      {array            arrayname}
  376+       ains+array bit+indirect bit,
  377+      {namearray}
  378+       ains+arrayname bit+indirect bit,
  379+      {namearrayname}
  380+       0
  381       {null}
  382  
  383  
  384     !operators
  385  
  386     %const %integer  not  = 7
  387     %const %integer  neg  = 8
  388     %const %integer  add  = 9
  389     %const %integer  sub  = 10
  390     %const %integer  bsub = 11
  391     %const %integer  bic  = 12
  392     %const %integer  or   = 13
  393     %const %integer  xor  = 14
  394     %const %integer  lsh  = 15
  395     %const %integer  rsh  = 16
  396     %const %integer  div  = 17
  397     %const %integer  bslh = 18
  398     %const %integer  brsh = 19
  399     %const %integer  bdiv = 20
  400     %const %integer  exp  = 21
  401     %const %integer  rexp = 22
  402     %const %integer  rdiv = 23
  403     %const %integer  bexp = 24
  404     %const %integer  brexp= 25
  405     %const %integer  brdiv= 26
  406     %const %integer  mul  = 27
  407     %const %integer  remy = 28
  408     %const %integer  brem = 29
  409  
  410     !primitive routines
  411  
  412     %const %integer  prim rts          = 26; ! number of last routine
  413  
  414     %const %integer  set dv            =  1; ! A  create dope vect on stack
  415     %const %integer  adec              =  2; ! B  declare array space
  416     %const %integer  test ass          =  3; ! C  %signal if unassigned
  417  !  %const %integer                    =  4; ! D  set up %for block (old)
  418  !  %const %integer                    =  5; ! E  V6 resolution
  419     %const %integer  check resolution  =  6; ! F  %signal if res fails
  420  !  %const %integer  for test          =  7; ! G  test %for validity
  421     %const %integer  stop              =  8; ! H  %signal 0, 0, 0
  422  !  %const %integer  smove             =  9; ! I  unused!!!!!
  423     %const %integer  for test          = 10; ! J  ** new %for test
  424     %const %integer  scomp             = 11; ! K  compare strings lexically
  425     %const %integer  monit             = 12; ! L  call diag routine
  426     %const %integer  proc enter        = 13; ! M  call proc param
  427     %const %integer  exp int           = 14; ! N  integer exponentiation
  428     %const %integer  exp real          = 15; ! O  real exponentiation
  429     %const %integer  signal            = 16; ! P  %signal
  430     %const %integer  arefn             = 17; ! Q  multi-dim array ref
  431     %const %integer  a ref             = 18; ! R  single dim array ref (check)
  432     %const %integer  sw jump           = 19; ! S  switch jump
  433     %const %integer  rch               = 20; ! T  read ch
  434     %const %integer  rsym              = 21; ! U  read symbol
  435     %const %integer  pch               = 22; ! V  print ch
  436     %const %integer  psym              = 23; ! W  print symbol
  437     %const %integer  char num          = 24; ! X  charno (checks range)
  438     %const %integer  test string ovf   = 25; ! Y  string length check
  439     %const %integer  resolution        = 26; ! Z  perform resolution
  440  
  441     %const %byte %array  prim mask (1 : primrts) =
  442+       16_3C, 16_20, 16_00, 16_00, 16_3C,
  443+       16_00, 16_00, 16_00, 16_00, 16_00,
  444+       16_3C, 16_00, 16_00, 16_00, 16_3C,
  445+       16_00, 16_3C, 16_08, 16_00, 16_0C,
  446+       16_0C, 16_0C, 16_0C, 16_00, 16_00,
  447+       16_00
  448  
  449     !opcode flag bits
  450  
  451     %const %integer one bit = 16_0100,     {one operand}
  452+                    two bit = 16_0200,     {two operand}
  453+                    add bit = 16_0400,     {add operation}
  454+                    sub bit = 16_0800,     {subtract operation}
  455+                   addr bit = 16_1000,     {address operation}
  456+                   move bit = 16_2000,     {move operation}
  457+                    commute = 16_4000,     {commutative op}
  458+                 reversible = 16_8000      {order of operands unimportant}
  459  
  460     %const %integer  no short  = 16_10000;  ! use char instr in STRING3
  461     %const %integer  len check = 16_20000;  ! check length on string op
  462     %const %integer  no ass chk = 16_40000  {omit string assigned check}
  463  
  464     !opcodes
  465  
  466     %const %integer  movl   = 1*8+move bit+one bit+two bit
  467     %const %integer  mnegl  = 0*8
  468     %const %integer  mcoml  = 3*8
  469     %const %integer  addl   = 14*8+add bit+one bit+two bit+commute
  470     %const %integer  subl   = 15*8+sub bit+one bit+two bit
  471     %const %integer  bicl   = 18*8+two bit
  472     %const %integer  bisl   = 19*8+two bit+commute
  473     %const %integer  xorl   = 20*8+two bit+commute
  474     %const %integer  bitl   = 21*8+commute+reversible
  475     %const %integer  mull   = 16*8+two bit+commute
  476     %const %integer  divl   = 17*8+two bit
  477     %const %integer  moval  = 2*8+addr bit, movab = moval+2
  478     %const %integer  clrl   = 6*8
  479  
  480     %const %integer  tstl   = 29*8
  481     %const %integer  cmpl   = 30*8, cmpd = cmpl+4, cmpw = cmpl+1
  482  
  483     %const %integer  calls  = 0*8+7
  484     %const %integer  jsb    = 1*8+7
  485     %const %integer  ret    = 2*8+7
  486  
  487     %const %integer  sobgtr = 12*8+7
  488  
  489     %const %integer  ashq   = 17*8+6
  490     %const %integer  ashl   = 17*8+5
  491     %const %integer  ediv   = 17*8+7
  492  
  493     %const %integer  incl   = 12*8
  494     %const %integer  movzbl = 9*8,   movzwl = 9*8+7
  495     %const %integer  movq   = 1*8+5, movw = movl+1, movb = movl+2
  496     %const %integer  movd   = 1*8+4, movf = 1*8+3
  497     %const %integer  pushal = 5*8 + addr bit
  498     %const %integer  pushl  = 4*8
  499  
  500     %const %integer  movc3  = 3*8+6, cmpc3 = 30*8+6
  501     %const %integer  movc5  = 3*8+7
  502  
  503     %const %integer  mnegd  = mnegl+4
  504     %const %integer  addd   = addl+4, addb2 = addl+2
  505     %const %integer  subd   = subl+4
  506     %const %integer  muld   = mull+4
  507     %const %integer  divd   = divl+4
  508  
  509     %const %integer  cvtlw  = 7*8+1
  510     %const %integer  cvtld  = 7*8+4
  511     %const %integer  movpsl = 4*8+7
  512     %const %integer  extzv  = 10*8+7, extv = 11*8+7
  513  
  514     ! sundry actual op-codes
  515     %const %integer  bicpsw vbit = 16_20B9;  ! Clear V-bit in PSW
  516     %const %integer  bispsw vbit = 16_20B8;  !   Set V-bit in PSW
  517     %const %integer  bgeq        = 16_18;    ! Branch if >= (0), for |X|
  518  
  519     %const %integer  three op = 8*8
  520  
  521     %record %format  varfm (%c
  522+       %integer  disp, length, extra, zeroad, header,
  523+       %short  format, xno,
  524+       %byte  type, form, base, flags)
  525  
  526     %record %format  stackfm (%c
  527+       (%integer  disp, mantissa %or %longreal lrval),
  528+       %integer extra, length, header,
  529+       %short  format, xno,
  530+       %byte  type, form, base, oper, flags, index, iscale,
  531+       %record(stackfm) %name link )
  532  
  533     !data formats
  534  
  535     %record %format  dfm (%record(stackfm) %name  d, %record(dfm) %name  link)
  536     %record %format  labelfm (%short  id, tag)
  537  
  538     %own %integer  specs        = 0;       !size of spec area (code)
  539     %own %integer  ca           = 0;       !current code address
  540     %own %integer  ga           = 0;       !current gla address
  541     %own %integer  cp           = 0;       !code buffer pointer
  542     %own %integer  gp           = 0;       !gla buffer pointer
  543     %own %integer  diag lines   = 0;       !size of line info
  544     %own %integer  diag size    = 0;       !size of diag tables
  545     %own %integer  sym          = 0;       !current code symbol
  546     %own %integer  code         = 0;       !current coded code symbol
  547     %own %integer  errors       = 0;       !total errors
  548     %own %integer  line error   = 0;       !flag for errors on this line
  549     %own %integer  current line = 0
  550     %own %integer  stp          = 0
  551     %own %integer  data size    = 0
  552     %own %integer  ivbit state  = 0;       ! for overflow masking
  553     %own %integer  entry mask   = 0;       !proc entry mask
  554     %own %integer  frame        = 0;       !current stack frame limit
  555     %own %integer  last local;             !local limit for unass check
  556     %own %integer  level        = -1
  557     %own %integer  unsigned     = 0
  558     %own %integer  invert       = 0;       !condition inversion flag
  559     %own %integer  uncond jump  = 0
  560     %own %integer  last movc3   = -1;      !address of MOVC3
  561     %own %integer  gmode        = 0;       !parameter-format flag
  562     %own %integer  gtype        = 0;       !    do.
  563     %own %integer  last ref     = 0
  564     %own %integer  evno         = 0;       !event trap counter
  565     %own %integer  ownval, mantissa;       !***Own and order critical***
  566     %own %integer  discard
  567     %own %integer  index regs   = 0
  568     %own %integer  active regs  = 0
  569     %integer  parms = max vars+1;          !start of parameter area
  570     %integer  local = 0;                   !local base register
  571     %integer  otype, potype = 0
  572     %integer  decl;                        !last descriptor index
  573     %integer  owntype, ownform
  574     %integer  spec
  575     %integer  vlb, vub;                    !vector bounds
  576     %integer  j, n
  577  
  578     %const %record(*) %name  null == 0
  579  
  580     %record(stackfm) %name  lhs, rhs
  581     %record(stackfm) %name desc asl
  582     %record(dfm) %name dasl
  583     %record(dfm) using
  584     %record(varfm) %name decvar
  585     %record(varfm) %name  formal, actual
  586  
  587     %own %byte %array  code buffer (1 : 128)
  588     %own %byte %array  gla  buffer (1 : 128)
  589  
  590     %own %record(varfm)  begin
  591  
  592     %external %string(max ident) %spec  entryname
  593     %own %string(255) text;                !for string constants
  594     %own %string(max ident)  external name, alias, var name
  595  
  596     %own %record(stackfm) %array  regv (r0 : fpr4)
  597     %own %integer %array  activity (0 : fpr4) = 0(*)
  598     %own %integer %array  used     (0 : fpr4) = 0(*)
  599     %own %byte    %array  indx     (r0 : r10)  = 0(*)
  600  
  601     %record(stackfm)  head, dope, zeroth
  602     %record(stackfm)  zero v
  603     %record(stackfm)  gla work;       !used for clearing records
  604     %record(stackfm)  spv;            ! => -(SP) operand
  605  
  606     %record(stackfm) %name %array  stacked (1 : max depth)
  607     %record(dfm) %array  dlist (0 : max stack)
  608     %record(stackfm) %array  stak (0 : max stack)
  609     %record(labelfm) %array  labels (1 : max labels)
  610     %record(varfm) %array  var (0 : max vars)
  611  
  612  
  613     %const %short %array  op map (add : brem) =
  614+       addl+three op, subl+three op, 0, bicl+three op,
  615+       bisl+three op, xorl+three op, 0, 0,
  616+       divl+three op, 0(9), mull+three op, 0(2)
  617  
  618     !0 = ok, 1 = same, 2 = never
  619     %const %byte %array  trans (add : brem) =
  620+             0, 0,
  621+       0, 2, 1, 1,
  622+       2, 2, 2, 2,
  623+       2, 2, 2, 2,
  624+       2, 2, 2, 2,
  625+       1, 2, 2
  626  
  627     %const %byte %array  comm (add : brem) =
  628+             1, 0,
  629+       0, 0, 1, 1,
  630+       0, 0, 0, 0,
  631+       0, 0, 0, 0,
  632+       0, 0, 0, 0,
  633+       1, 0, 0
  634  
  635     %const %integer  no null = 2
  636  
  637     ! values of RH for which LH oper RH = LH:   2 => no value
  638     %const %integer %array  rnull op (add : brem) =
  639+             0, 0,
  640+       0, 0, 0, 0,
  641+       0, 0, 1, 0,
  642+       2, 2, 1, 1,
  643+       1, 2, 2, 2,
  644+       1, 2, 2
  645  
  646     ! values of LH for which LH oper RH = RH:   2 => no value
  647     %const %integer %array  lnull op (add : brem) =
  648+             0, 2,
  649+       0, 2, 0, 0,
  650+       2, 2, 2, 2,
  651+       2, 2, 2, 2,
  652+       2, 2, 2, 2,
  653+       1, 2, 2
  654  
  655  !   %const %byte %array  op real (not : brem) =
  656  !      0, 1, 1, 1,
  657  !      0, 0, 0, 0,
  658  !      0, 0, 0, 0,
  659  !      0, 0, 0, 1,
  660  !      1, 0, 0, 0,
  661  !      1, 0, 0
  662  
  663     %const %string(4) %array  op name (not : brem) =
  664+       "U\",  "U-",  "+",   "-",
  665+       "B-",  "BIC", "!",   "!!",
  666+       "<<",  ">>",  "//",  "B<<",
  667+       "B>>", "B/",  "^^",  "^",
  668+       "/",   "B^^", "B^",  "B/",
  669+       "*",   "REM", "BREM"
  670  
  671     !opcode table
  672  
  673     %const %byte %array  op code (0 : 31*8-1) =
  674+          16_ce, 16_ae, 16_8e, 16_52, 16_72,     0,     0, 16_fb,
  675+    ! 0   mnegl  mnegw  mnegb  mnegf  mnegd      -      -  calls
  676+          16_d0, 16_b0, 16_90, 16_50, 16_70, 16_7d,     0, 16_16,
  677+    ! 1   movl   movw   movb   movf   movd   movq       -  jsb
  678+          16_de, 16_3e, 16_9e, 16_de, 16_7e, 16_7e,     0, 16_04,
  679+    ! 2   moval  movaw  movab  movaf  movad  movaq      -  ret
  680+          16_d2, 16_b2, 16_92,     0,     0,     0, 16_28, 16_2c,
  681+    ! 3   mcoml  mcomw  mcomb      -      -      -  movc3  movc5
  682+          16_dd,     0,     0,     0,     0,     0,     0, 16_dc,
  683+    ! 4   pushl      -      -      -      -      -      -  movpsl
  684+          16_df, 16_3f, 16_9f, 16_df, 16_7f, 16_7f,     0,     0,
  685+    ! 5   pushal pushaw pushab pushaf pushad pushaq     -      -
  686+          16_d4, 16_b4, 16_94, 16_d4, 16_7c, 16_7c,     0,     0,
  687+    ! 6   clrl   clrw   clrb   clrf   clrd   clrq       -      -
  688+          16_d0, 16_f7, 16_90, 16_4e, 16_6e,     0,     0,     0,
  689+    ! 7   movl   cvtlw  movb   cvtlf  cvtld      -      -      -
  690+          16_32, 16_b0, 16_90, 16_4d, 16_6d,     0,     0,     0,
  691+    ! 8   cvtwl  movw   movb   cvtwf  cvtwd      -      -      -
  692+          16_9a, 16_9b, 16_90, 16_4c, 16_6c,     0,     0, 16_3c,
  693+    ! 9   movzbl movzbw movb   cvtbf  cvtbd      -      -  movzwl
  694+          16_4a, 16_49, 16_48, 16_50, 16_56,     0, 16_4b, 16_ef,
  695+    !10   cvtfl  cvtfw  cvtfb  movf   cvtfd      -  cvtrfl extzv
  696+          16_6a, 16_69, 16_68, 16_76, 16_70,     0, 16_6b, 16_ee,
  697+    !11   cvtdl  cvtdw  cvtdb  cvtdf  movd       - cvtrdl  extv
  698+          16_d6, 16_b6, 16_96,     0,     0,     0,     0, 16_f5,
  699+    !12   incl   incw   incb       -      -      -      -  sobgtr
  700+          16_d7, 16_b7, 16_97,     0,     0,     0,     0,     0,
  701+    !13   decl   decw   decb       -      -      -      -      -
  702+          16_c0, 16_a0, 16_80, 16_40, 16_60,     0,     0,     0,
  703+    !14   addl2  addw2  addb2  addf2  addd2      -      -      -
  704+          16_c2, 16_a2, 16_82, 16_42, 16_62,     0,     0,     0,
  705+    !15   subl2, subw2, subb2, subf2, subd2      -      -      -
  706+          16_c4, 16_a4, 16_84, 16_44, 16_64,     0,     0,     0,
  707+    !16   mull2  mulw2  mulb2  mulf2  muld2      -      -      -
  708+          16_c6, 16_a6, 16_86, 16_46, 16_66, 16_78, 16_79, 16_7b,
  709+    !17   divl2  divw2  divb2  divf2  divd2   ashl   ashq   ediv
  710+          16_ca, 16_aa, 16_8a,     0,     0,     0,     0,     0,
  711+    !18   bicl2  bicw2  bicb2      -      -      -      -      -
  712+          16_c8, 16_a8, 16_88,     0,     0,     0,     0,     0,
  713+    !19   bisl2  bisw2  bisb2      -      -      -      -      -
  714+          16_cc, 16_ac, 16_8c,     0,     0,     0,     0,     0,
  715+    !20   xorl2  xorw2  xorb2      -      -      -      -      -
  716+          16_d3, 16_b3, 16_93,     0,     0,     0,     0,     0,
  717+    !21   bitl   bitw   bitb       -      -      -      -      -
  718+          16_c1, 16_a1, 16_81, 16_41, 16_61,     0,     0,     0,
  719+    !22   addl3  addw3  addb3  addf3  addd3      -      -      -
  720+          16_c3, 16_a3, 16_83, 16_43, 16_63,     0,     0,     0,
  721+    !23   subl3  subw3  subb3  subf3  subd3      -      -      -
  722+          16_c5, 16_a5, 16_85, 16_45, 16_65,     0,     0,     0,
  723+    !24   mull3  mulw3  mulb3  mulf3  muld3      -      -      -
  724+          16_c7, 16_a7, 16_87, 16_47, 16_67,     0,     0,     0,
  725+    !25   divl3  divw3  divb3  divf3  divd3      -      -      -
  726+          16_cb, 16_ab, 16_8b,     0,     0,     0,     0,     0,
  727+    !26   bicl3  bicw3  bicb3      -      -      -      -      -
  728+          16_c9, 16_a9, 16_89,    0,     0,     0, 16_b9, 16_b8,
  729+    !27   bisl3  bisw3  bisb3      -      -      - bicpsw bispsw
  730+          16_cd, 16_ad, 16_8d,     0,     0,     0,     0,     0,
  731+    !28   xorl3  xorw3  xorb3      -      -      -      -      -
  732+          16_d5, 16_b5, 16_95, 16_53, 16_73,     0,     0,     0,
  733+    !29   tstl   tstw   tstb   tstf   tstd       -      -      -
  734+          16_d1, 16_b1, 16_91, 16_51, 16_71, 16_71, 16_29, 16_2d
  735     !30   cmpl   cmpw   cmpb   cmpf   cmpd   cmpd   cmpc3  cmpc5
  736  
  737     !bit significance:
  738  
  739     %const %integer check1 = 2_0000 0001,
  740+                    check2 = 2_0000 0010,
  741+                    check3 = 2_0000 0100,
  742+               move check  = 2_0000 1000
  743  
  744     %const %byte %array  operand bits (0 : 255) =
  745+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  746+ !  0 halt        nop         rei         bpt         ret         rsb
  747+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  748+ !  6 ldpctx      svpctx      cvtps       cvtsp       index       crc
  749+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  750+ ! 12 prober      probew      insque      remque      bsbb        brb
  751+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  752+ ! 18 bneq        beql        bgtr        bleq        jsb         jmp
  753+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  754+ ! 24 bgeq        blss        bgtru       blequ       bvc         bvs
  755+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  756+ ! 30 bgequ       blssu       addp4       addp6       subp4       subp6
  757+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  758+ ! 36 cvtpt       mulp        cvttp       divp        movc3       cmpc3
  759+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  760+ ! 42 scanc       spanc       movc5       cmpc5       movtc       movtuc
  761+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  762+ ! 48 bsbw        brw         cvtwl       cvtwb       movp        comp3
  763+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  764+ ! 54 cvtpl       cmpp4       editpc      matchc      locc        skpc
  765+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0011,2_0000 0011,
  766+ ! 60 movzwl      acbw        movaw       pushaw      addf2       addf3
  767+    2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
  768+ ! 66 subf2       subf3       mulf2       mulf3       divf2       divf3
  769+    2_0000 0001,2_0000 0001,2_0000 0001,2_0000 0001,2_0000 0000,2_0000 0000,
  770+ ! 72 cvtfb       cvtfw       cvtfl       cvtrfl      cvtbf
  771+    2_0000 0001,2_0000 0000,2_0000 1001,2_0000 0011,2_0000 0001,2_0000 0001,
  772+ ! 78 cvtlf       acbf        movf        cmpf        mnegf       tstf
  773+    2_0000 0000,2_0000 0000,2_0000 0001,2_0000 0000,2_0000 0000,2_0000 0000,
  774+ ! 84 emodf       polyf       cvtfd                   adawi
  775+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  776+ ! 90
  777+    2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
  778+ ! 96 addd2       addd3       subd2       subd3       muld2       muld3
  779+    2_0000 0011,2_0000 0011,2_0000 0001,2_0000 0001,2_0000 0001,2_0000 0001,
  780+ !102 divd2       divd3       cvtdb       cvtdw       cvtdl       cvtrdl
  781+    2_0000 0000,2_0000 0000,2_0000 0001,2_0000 0000,2_0000 1001,2_0000 0001,
  782+ !108 cvtbd       cvtwd       cvtld       acbd        movd        cmpd
  783+    2_0000 0001,2_0000 0001,2_0000 0000,2_0000 0000,2_0000 0001,2_0000 0000,
  784+ !114 mnegd       tstd        emodd       polyd       cvtdf
  785+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  786+ !120 ashl        ashq        emul        ediv        clrq        movq
  787+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  788+ !126 movaq       pushaq      addb2       addb3       subb2       subb3
  789+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  790+ !132 mulb2       mulb3       devb2       divb3       bisb2       misb3
  791+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  792+ !138 bicb2       bicb3       xorb2       xorb3       mnegb       caseb
  793+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  794+ !144 movb        cmpb        mcomb       bitb        clrb        tstb
  795+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  796+ !150 incb        decb        cvtbl       cvtbw       movzbl      movzbw
  797+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  798+ !156 rotl        acbb        movab       pushab      addw2       addw3
  799+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  800+ !162 subw2       subw3       mulw2       mulw3       divw2       divw3
  801+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  802+ !168 bisw2       bisw3       bicw2       bicw3       xorw2       xorw3
  803+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  804+ !174 mnegw       casew       movw        cmpw        mcomw       bitw
  805+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  806+ !180 clrw        tstw        incw        decw        bispsw      bicpsw
  807+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  808+ !186 popr        pushr       chmk        chme        chms        chmu
  809+    2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
  810+ !192 addl2       addl3       subl2       subl3       mull2       mull3
  811+    2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,2_0000 0011,
  812+ !198 divl2       divl3       bisl2       bisl3       bicl2       bicl3
  813+    2_0000 0011,2_0000 0011,2_0000 0001,2_0000 0000,2_0000 1001,2_0000 0011,
  814+ !204 xorl2       xorl3       mnegl       casel       movl        cmpl
  815+    2_0000 0001,2_0000 0011,2_0000 0000,2_0000 0001,2_0000 0001,2_0000 0001,
  816+ !210 mcoml       bitl        clrl        tstl        incl        decl
  817+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0001,
  818+ !216 adwc        sbwc        mtpr        mfpr        movpsl      pushl
  819+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  820+ !222 moval       pushal      bbs         bbc         bbss        bbcs
  821+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  822+ !228 bbsc        bbcc        bbssi       bbcci       blbs        blbc
  823+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  824+ !234 ffs         ffc         cmpv        cmpzv       extv        extzv
  825+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  826+ !240 insv        acbl        aoblss      aobleq      sobgeq      sobgtr
  827+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000,
  828+ !246 cvtlb       cvtlw       ashp        cvtlp       callg       calls
  829+    2_0000 0000,2_0000 0000,2_0000 0000,2_0000 0000
  830  !252 xfc
  831  
  832     !diagnostic tables
  833  
  834     %const %string(3)%array  reg name (0 : 20) =
  835+       "???", " R0", " R1", " R2", " R3", " R4", " R5", " R6", " R7",
  836+       " R8", " R9", "R10", "GLA", " AP", " FP", " SP", " PC", "Any",
  837+       " F0", " F2", " F4"
  838  
  839     %const %string(6) %array  op mnem (0 : 255) =
  840+       "HALT",   "NOP",    "REI",    "BPT",    "RET",    "RSB",
  841+       "LDPCTX", "SVPCTX", "CVTPS",  "CVTSP",  "INDEX",  "CRC",
  842+       "PROBER", "PROBEW", "INSQUE", "REMQUE", "BSBB",   "BRB",
  843+       "BNEQ",   "BEQL",   "BGTR",   "BLEQ",   "JSB",    "JMP",
  844+       "BGEQ",   "BLSS",   "BGTRU",  "BLEQU",  "BVC",    "BVS",
  845+       "BGEQU",  "BLSSU",  "ADDP4",  "ADDP6",  "SUBP4",  "SUBP6",
  846+       "CVTPT",  "MULP",   "CVTTP",  "DIVP",   "MOVC3",  "CMPC3",
  847+       "SCANC",  "SPANC",  "MOVC5",  "CMPC5",  "MOVTC",  "MOVTUC",
  848+       "BSBW",   "BRW",    "CVTWL",  "CVTWB",  "MOVP",   "COMP3",
  849+       "CVTPL",  "CMPP4",  "EDITPC", "MATCHC", "LOCC",   "SKPC",
  850+       "MOVZWL", "ACBW",   "MOVAW",  "PUSHAW", "ADDF2",  "ADDF3",
  851+       "SUBF2",  "SUBF3",  "MULF2",  "MULF3",  "DIVF2",  "DIVF3",
  852+       "CVTFB",  "CVTFW",  "CVTFL",  "CVTRFL", "CVTBF",  "?????",
  853+       "CVTLF",  "ACBF",   "MOVF",   "CMPF",   "MNEGF",  "TSTF",
  854+       "EMODF",  "POLYF",  "CVTFD",  "?????",  "ADAWI",  "?????",
  855+       "?????",  "?????",  "?????",  "?????",  "?????",  "?????",
  856+       "ADDD2",  "ADDD3",  "SUBD2",  "SUBD3",  "MULD2",  "MULD3",
  857+       "DIVD2",  "DIVD3",  "CVTDB",  "CVTDW",  "CVTDL",  "CVTRDL",
  858+       "CVTBD",  "CVTWD",  "CVTLD",  "ACBD",   "MOVD",   "CMPD",
  859+       "MNEGD",  "TSTD",   "EMODD",  "POLYD",  "CVTDF",  "?????",
  860+       "ASHL",   "ASHQ",   "EMUL",   "EDIV",   "CLRQ",   "MOVQ",
  861+       "MOVAQ",  "PUSHAQ", "ADDB2",  "ADDB3",  "SUBB2",  "SUBB3",
  862+       "MULB2",  "MULB3",  "DEVB2",  "DIVB3",  "BISB2",  "BISB3",
  863+       "BICB2",  "BICB3",  "XORB2",  "XORB3",  "MNEG",   "CASEB",
  864+       "MOVB",   "CMPB",   "MCOMB",  "BITB",   "CLRB",   "TSTB",
  865+       "INCB",   "DECB",   "CVTBL",  "CVTBW",  "MOVZBL", "MOVZBW",
  866+       "ROTL",   "ACBB",   "MOVAB",  "PUSHAB", "ADDW2",  "ADDW3",
  867+       "SUBW2",  "SUBW3",  "MULW2",  "MULW3",  "DIVW2",  "DIVW3",
  868+       "BISW2",  "BISW3",  "BICW2",  "BICW3",  "XORW2",  "XORW3",
  869+       "MNEGW",  "CASEW",  "MOVW",   "CMPW",   "MCOMW",  "BITW",
  870+       "CLRW",   "TSTW",   "INCW",   "DECW",   "BISPSW", "BICPSW",
  871+       "POPR",   "PUSHR",  "CHMK",   "CHME",   "CHMS",   "CHMU",
  872+       "ADDL2",  "ADDL3",  "SUBL2",  "SUBL3",  "MULL2",  "MULL3",
  873+       "DIVL2",  "DIVL3",  "BISL2",  "BISL3",  "BICL2",  "BICL3",
  874+       "XORL2",  "XORL3",  "MNEGL",  "CASEL",  "MOVL",   "CMPL",
  875+       "MCOML",  "BITL",   "CLRL",   "TSTL",   "INCL",   "DECL",
  876+       "ADWC",   "SBWC",   "MTPR",   "MFPR",   "MOVPSL", "PUSHL",
  877+       "MOVAL",  "PUSHAL", "BBS",    "BBC",    "BBSS",   "BBCS",
  878+       "BBSC",   "BBCC",   "BBSSI",  "BBCCI",  "BLBS",   "BLBC",
  879+       "FFS",    "FFC",    "CMPV",   "CMPZV",  "EXTV",   "EXTZV",
  880+       "INSV",   "ACBL",   "AOBLSS", "AOBLEQ", "SOBGEQ", "SOBGTR",
  881+       "CVTLB",  "CVTLW",  "ASHP",   "CVTLP",  "CALLG",  "CALLS",
  882+       "XFC",    "????"(*)
  883  
  884  
  885     %routine %spec  FLUSH CODE
  886     %routine %spec  HAZARD (%integer reg)
  887     %routine %spec  CLAIM (%integer reg)
  888     %routine %spec  RELEASE (%integer reg)
  889     %routine %spec  PRIM (%integer n)
  890     %integer %function %spec  SCALE TYPE (%integer length)
  891     %record(stackfm) %map %spec  LITERAL (%integer n)
  892     %record(stackfm) %map %spec  TEMP (%integer size)
  893  
  894  
  895     !******** initialisation *********
  896  
  897     regv(r0)_base = r0;  regv(r0)_type = integers;  regv(r0)_form=vinr
  898     regv(r1)_base = r1;  regv(r1)_type = integers;  regv(r1)_form=vinr
  899     regv(r2)_base = r2;  regv(r2)_type = integers;  regv(r2)_form=vinr
  900     regv(r3)_base = r3;  regv(r3)_type = integers;  regv(r3)_form=vinr
  901     regv(r4)_base = r4;  regv(r4)_type = integers;  regv(r4)_form=vinr
  902     regv(r5)_base = r5;  regv(r5)_type = integers;  regv(r5)_form=vinr
  903     regv(r6)_base = r6;  regv(r6)_type = integers;  regv(r6)_form=vinr
  904     regv(r7)_base = r7;  regv(r7)_type = integers;  regv(r7)_form=vinr
  905     regv(r8)_base = r8;  regv(r8)_type = integers;  regv(r8)_form=vinr
  906     regv(r9)_base = r9;  regv(r9)_type = integers;  regv(r9)_form=vinr
  907     regv(r10)_base= r10; regv(r10)_type= integers; regv(r10)_form=vinr
  908     regv(gla)_base= gla; regv(gla)_type= integers; regv(gla)_form=vinr
  909     regv(fp)_base = fp;  regv(fp)_type = integers;  regv(fp)_form=vinr
  910     regv(ap)_base = ap;  regv(ap)_type = integers;  regv(ap)_form=vinr
  911     regv(sp)_base = sp;  regv(sp)_type = integers;  regv(sp)_form=vinr
  912     regv(pc)_base = pc;  regv(pc)_type = integers;  regv(pc)_form=vinr
  913     regv(fpr0)_base=fpr0; regv(fpr0)_type = reall;  regv(fpr0)_form = vinr
  914     regv(fpr2)_base=fpr2; regv(fpr2)_type = reall;  regv(fpr2)_form = vinr
  915     regv(fpr4)_base=fpr4; regv(fpr4)_type = reall;  regv(fpr4)_form = vinr
  916  
  917     zerov = 0
  918     zerov_type = integers;  zerov_form = constant
  919  
  920     gla work = 0
  921     gla work_type = integers;  gla work_form = v in s
  922     gla work_base = gla
  923  
  924     spv = 0
  925     spv_type = integers;  spv_form = v in s
  926     spv_base = sp;   spv_flags = auto d
  927  
  928     zeroth = 0
  929     zeroth_type = integers; zeroth_form = v in s
  930  
  931     dope = 0
  932     dope_base = gla; dope_type = integers; dope_form = v in s
  933  
  934     head = 0
  935     head_type = integers; head_form = v in s
  936  
  937     select input tank (icode);  select output tank (object)
  938     select output (diag stream)
  939  
  940     var(0) = 0
  941     activity(pc)  = -1
  942     activity(sp)  = -1
  943     activity(fp)  = -1
  944     activity(ap)  = -1
  945     activity(gla) = -1
  946     activity(0)   = -1
  947  
  948     %for j = 0, 1, max stack-1 %cycle
  949        stak(j)_link == stak(j+1)
  950        dlist(j)_link == dlist(j+1)
  951     %repeat
  952  
  953     stak(max stack)_link == null
  954     dlist(max stack)_link == null
  955     desc asl == stak(0)
  956     dasl == dlist(0)
  957  
  958     using_link == null
  959  
  960     decvar == begin
  961  
  962     !********************************************
  963  
  964  
  965  ! Utilities
  966  
  967     %predicate  ZERO (%record(stackfm) %name v)
  968        ! check descriptor for zero
  969        %false %unless v_form = constant %and v_type&(integers!reals) # 0
  970        %false %unless v_disp = 0 %and v_oper = 0
  971        %false %if v_type = reall %and v_mantissa # 0
  972        %true
  973     %end
  974  
  975     %predicate  CONST (%record(stackfm) %name v)
  976        ! check descriptor for a constant value (integer)
  977        %true %if v_form = constant %and v_oper = 0 %and v_type&integers # 0
  978        %false
  979     %end
  980  
  981     %predicate  SAME (%record(stackfm) %name  a, b)
  982        %switch  f (constant : a in rec)
  983        %false %unless a_oper = 0 = b_oper %c
  984+                 %and a_flags&indexed = 0 = b_flags&indexed %c
  985+                 %and a_type = b_type     %c
  986+                 %and a_form = b_form     %c
  987+                 %and a_xno  = b_xno      %c
  988+                 %and a_flags = b_flags
  989        %if a_type&records # 0 %start
  990           %false %unless a_format = b_format
  991        %finish
  992        -> f (a_form&7)
  993     f(constant):
  994        %true %if a_type&integers # 0 %and a_disp  = b_disp
  995        %true %if a_type&real bit # 0 %and a_lrval = b_lrval
  996        %false
  997     f(v in rec):
  998     f(a in rec):
  999     f(av in rec):
 1000        %false %unless a_extra = b_extra
 1001     f(v in s):
 1002     f(a in s):
 1003     f(av in s):
 1004        %false %unless a_disp = b_disp
 1005     f(v in r):
 1006        %false %unless a_base = b_base
 1007        %true
 1008     %end
 1009  
 1010     %predicate  FLOATING (%record(stackfm) %name  v)
 1011        %true  %if v_type&real bit # 0
 1012        %false %if v_oper <= neg
 1013        %true  %if v_oper = rdiv %or v_oper = rexp
 1014        %false %if v_link_type&real bit = 0
 1015        %true
 1016     %end
 1017  
 1018     %predicate  IN FREE REG (%record(stackfm) %name  v)
 1019        ! true if v is in a useable register
 1020        %false %unless v_form = v in r
 1021        %false %unless activity(v_base) = 1
 1022        %true
 1023     %end
 1024  
 1025  
 1026  !diagnostics
 1027  
 1028     %string(15) %function  TYPE STR (%integer type, max)
 1029        %string(15)  res = ""
 1030        %integer  i
 1031        %const %byte %array  tbits (0 : 9) =
 1032+          0, records, strings, strings!in work, reall, reals,
 1033+          integers+short, integers+long, integers+byte, integers
 1034        %const %string(15) %array  tstr (0 : 9) =
 1035+          "no-type", "record  ", "string  ", "w/string", "l-real  ",
 1036+          "real    ","shortinteger", "long integer", "byte integer",
 1037+          "integer "
 1038        type = type & 16_FF
 1039        %for i = 0, 1, 9 %cycle
 1040           res = tstr(i) %and %exit %if type = tbits(i)
 1041        %repeat
 1042        res = "type=" . itos(type,-3) %if res = ""
 1043        length(res) = max %if length(res) > max
 1044        %result = res
 1045     %end
 1046  
 1047     %routine  PREC (%record(stackfm) %name v)
 1048        %integer  op, val
 1049        %const %string(9) %array fmstr (0 : 7) =
 1050+          "constant ", "V-in-R   ", "V-in-S   ", "AV-in-S  ",
 1051+          "A-in-S   ", "V-in-Rec ", "AV-in-Rec", "A-in-Rec "
 1052  
 1053        %routine  NON ZERO (%integer n, %string(15) m)
 1054           %if n # 0 %start
 1055              print string (m)
 1056              write (n, 0)
 1057           %finish
 1058        %end
 1059  
 1060        %if v == null %start
 1061           print string ("(NULL!!!!!)")
 1062           newline
 1063           %return
 1064        %finish
 1065        %if v_form = 15 %start
 1066           print string ("Label")
 1067           spaces (17)
 1068        %else
 1069           print string (fmstr(v_form&7))
 1070           space;  print string (type str (v_type, 8))
 1071           space;  val = v_form & (\15)
 1072           %if val&arrayname bit # 0 %then print string ("AN") %c
 1073+          %else %if val&proc bit # 0 %then print string ("PR") %c
 1074+          %else spaces (2)
 1075        %finish
 1076        space;   write (v_mantissa, 5)
 1077        print symbol ('@') %if v_flags&(indexed!xdefer) = indexed!xdefer
 1078        write (v_disp, 5)
 1079        %if v_form # constant %start
 1080           print symbol ('-') %if v_flags&autod # 0 %and v_disp = 0
 1081           printsymbol ('(')
 1082           print string (reg name(v_base))
 1083           printsymbol (')')
 1084           print symbol ('+') %if v_flags&autoi # 0 %and v_disp = 0
 1085           %if v_flags&indexed # 0 %start
 1086              print symbol ('[')
 1087              print string (reg name(v_index))
 1088              print symbol (']')
 1089              write (v_iscale, 0); space
 1090           %finish
 1091           %if v_form >= v in rec %start
 1092              print string (": ")
 1093              write (v_extra, 0)
 1094           %finish
 1095        %finish
 1096        non zero (v_header, " hdr=")
 1097        non zero (v_xno, " xno=")
 1098        print string (" L="); write (v_length,0)
 1099        op = v_oper
 1100        %if op # 0 %start
 1101           print string (" oper=")
 1102           %if not <= op <= brem %start
 1103              print symbol ('"')
 1104              print string (op name(op))
 1105              print symbol ('"')
 1106              %if op > neg %start
 1107                 newline;  spaces (13)
 1108                 prec (v_link)
 1109                 %return
 1110              %finish
 1111           %else
 1112              write (op, 0)
 1113           %finish
 1114        %finish
 1115        newline
 1116     %end
 1117  
 1118     %routine  STACK DUMP
 1119        %integer  sp = stp
 1120        print string ("Stack:")
 1121        %if sp <= 0 %start
 1122           print string (" empty")
 1123           newline
 1124        %else
 1125           newline
 1126           %while sp > 0 %cycle
 1127              write (sp, 2);   spaces (10)
 1128              prec (stacked(sp));   sp = sp - 1
 1129           %repeat
 1130        %finish
 1131     %end
 1132  
 1133     %routine  MON REG (%string(20) s, %integer r)
 1134        print string (s);   print symbol (':')
 1135        spaces (11 - length(s))
 1136        print string (reg name(r))
 1137        newline
 1138     %end
 1139  
 1140     %routine  MONITOR (%record(stackfm) %name v, %string(15) s)
 1141        print string (s)
 1142        printsymbol (':')
 1143        spaces (12-length(s))
 1144        prec (v)
 1145        stack dump %if diag&4096 # 0
 1146        %monitor %if diag&8192 # 0
 1147     %end
 1148  
 1149     %routine  SHOW REGS
 1150        %integer  reg
 1151        print string ("Register activity: "); newline
 1152        print string ("  R0  R1  R2  R3  R4  R5  R6  R7  R8  R9 R10  F0  F2  F4")
 1153        newline
 1154        %for reg = r0, 1, r10 %cycle
 1155           %if activity(reg) < 0 %start
 1156              print string ("   L")
 1157           %else
 1158              write (activity(reg), 3)
 1159           %finish
 1160        %repeat
 1161        %for reg = fpr0, 1, fpr4 %cycle
 1162           %if activity(reg) < 0 %then print string ("   L") %c
 1163+                                %else write (activity(reg), 3)
 1164        %repeat
 1165        newline
 1166        print string ("[]")
 1167        write (indx(r0), -2)
 1168        write (indx(reg), 3) %for reg = r1, 1, r10
 1169        newline
 1170     %end
 1171  
 1172     %routine  ABORT (%integer n)
 1173        !report catastrophic failure and stop
 1174        flush code
 1175        select output (0)
 1176        newline
 1177        print string ("***Pass 2 fails ")
 1178        write (n, 0)
 1179        print string (" at line ")
 1180        write (current line, 0)
 1181        newlines (2)
 1182        show regs;   newline
 1183        stack dump;  newline
 1184        print string ("Using:")
 1185        %if using_link == null %start
 1186           print string (" empty")
 1187           newline
 1188        %else
 1189           newline
 1190           %while using_link ## null %cycle
 1191              spaces (13)
 1192              prec (using_link_d)
 1193              using_link == using_link_link
 1194           %repeat
 1195        %finish
 1196        newline
 1197        %monitor
 1198        exit (16_1000002C)    {1000002c is SS$_ABORT with the inhibit message bit set - could just use EXIT_FAILURE}
 1199        %stop;      ! we don't come back - let pass 1/2 know..
 1200     %end
 1201  
 1202     %routine  ERROR (%integer sym, %string(127) s)
 1203        %own %integer erred = 0
 1204        %integer st = report
 1205        %return %if line error # 0
 1206        line error = 1
 1207        %cycle
 1208           select output (st)
 1209           %if erred = 0 %start
 1210              print string ("Pass 2:")
 1211              newline
 1212           %finish
 1213           %if sym = '!' %start
 1214              print string ("**** Fatal error at line ")
 1215              write (current line, 0)
 1216              print symbol (':')
 1217           %else
 1218              print symbol (sym)
 1219              write (current line, 4)
 1220           %finish
 1221           spaces (2);   print string (s)
 1222           newline
 1223           %exit %if st # report
 1224           st = diag stream
 1225        %repeat
 1226        exit (fatal) %if sym = '!'
 1227        erred = 1
 1228        errors = errors + 1 %if sym # '?'
 1229     %end
 1230  
 1231     %integer %function  NEW TAG
 1232        %own %integer tag = 0
 1233        tag = tag + 1
 1234        %result = tag
 1235     %end
 1236  
 1237  !code planting routines
 1238  
 1239     %routine  SET LINE
 1240        %own %integer last line = 0
 1241        %return %if command & 8 = 0
 1242        %return %if last line = current line %or current line = 0
 1243        last line = current line
 1244        diag lines = diag lines + 6
 1245        put (obj line);  put word (current line)
 1246     %end
 1247  
 1248     %routine  FLUSH CODE
 1249        %return %if cp = 0
 1250        set line
 1251        put (obj code)
 1252        put (cp)
 1253        put block (cp, codebuffer(1))
 1254        cp = 0
 1255     %end
 1256  
 1257     %routine  PUT NUMBER BYTE (%integer n)
 1258        cp = cp + 1
 1259        code buffer(cp) = n&255
 1260        flush code %if cp > 120
 1261        ca = ca + 1
 1262     %end
 1263  
 1264     %routine  PUT CODE (%integer op)
 1265        op = op&255
 1266        put number byte (op)
 1267        %if diag&128 # 0 %start
 1268           print string ("Op code = ")
 1269           print string (op mnem(op))
 1270           newline
 1271        %finish
 1272     %end
 1273  
 1274     %routine  WORD (%integer n)
 1275        shortinteger(addr(codebuffer(cp+1))) = n
 1276        cp = cp + 2
 1277        flush code %if cp > 120
 1278        ca = ca + 2
 1279     %end
 1280  
 1281     %routine  LONGWORD (%integer n)
 1282        integer(addr(codebuffer(cp+1))) = n
 1283        cp = cp + 4
 1284        flush code %if cp > 120
 1285        ca = ca + 4
 1286     %end
 1287  
 1288     %routine FLUSH GLA
 1289        %return %if gp = 0
 1290        put (obj gla)
 1291        put long (ga-gp)
 1292        put (gp)
 1293        put block (gp, gla buffer(1))
 1294        gp = 0
 1295     %end
 1296  
 1297     %routine  INIT GLA (%integer count, size, val)
 1298        flush gla
 1299        put (obj glam)
 1300        put long (ga)
 1301        put long (val)
 1302        put long (count)
 1303        put long (size)
 1304        ga = ga + size*count
 1305     %end
 1306  
 1307     %routine  GBYTE (%integer v)
 1308        gp = gp + 1;  ga = ga + 1
 1309        gla buffer(gp) = v&255
 1310        flush gla %if gp > 120
 1311     %end
 1312  
 1313     %routine  GWORD (%integer v)
 1314        shortinteger(addr(glabuffer(gp+1))) = v
 1315        gp = gp + 2;  ga = ga + 2
 1316        flush gla %if gp > 120
 1317     %end
 1318  
 1319     %routine  GLONGWORD (%integer v)
 1320        integer(addr(glabuffer(gp+1))) = v
 1321        gp = gp + 4; ga = ga + 4
 1322        flush gla %if gp > 120
 1323     %end
 1324  
 1325     %routine  GFIX (%integer mask)
 1326        gbyte (0) %while ga&mask # 0
 1327     %end
 1328  
 1329     %integer %function  SCALE TYPE (%integer len)
 1330        %result = byte  %if len = 1;   ! byte
 1331        %result = short %if len = 2;   ! word
 1332        %result = 0     %if len = 4;   ! longword
 1333        %result = long  %if len = 8;   ! quadword (not double)
 1334        %result = -1
 1335     %end
 1336  
 1337     %integer %function  CTYPE (%integer  i)
 1338        ! Given an integer value, returns the type
 1339        ! code required to contain this value.
 1340        ! Note that this applies to IMP-type ranges
 1341        ! ie.  byte 0:255, NOT -128:127
 1342        ! result -1 means that the value may be contained
 1343        ! in a short literal operand (type irrelevant)
 1344        %result = -1    %if 0 <= i <= 63
 1345        %result = byte  %if 0 <= i <= 255
 1346        %result = short %if \16_7FFF <= i <= 16_7FFF
 1347        %result = 0 {int}
 1348     %end
 1349  
 1350     %integer %function  MSIZE (%integer val)
 1351        ! Returns the number of bytes required to
 1352        ! hold an integer constant of value 'val'
 1353        ! Note: value interpreted as machine signed
 1354        ! value.
 1355        ! (0 => short lit OK)
 1356        %result = 0 %if 0        <= val <= 63;     ! Short lit
 1357        %result = 1 %if -128     <= val <= 127
 1358        %result = 2 %if \16_7FFF <= val <= 16_7FFF
 1359        %result = 4
 1360     %end
 1361  
 1362     %predicate  FITS (%integer val, type)
 1363        ! True if the value val can be held
 1364        ! in an object of type 'type' (IMP-types)
 1365        %integer  vtype
 1366        type = type&7
 1367        vtype = ctype (val)
 1368        %true %if vtype < 0;        ! Short lit : OK
 1369        %true %if type = 0;         ! integer - OK
 1370        %true %if type = short %and vtype # 0
 1371        %true %if type = byte = vtype
 1372        %false
 1373     %end
 1374  
 1375     %integer %function  SHORT LITERAL (%record(stack fm) %name  v)
 1376        ! returns byte operand if v can be held as short lit,
 1377        ! otherwise -1
 1378        %if v_form = constant %and v_type&(integers!realbit) # 0 %start
 1379           %if v_type&integers # 0 %start
 1380              %result = v_disp %if 0 <= v_disp <= 63
 1381           %else %if v_mantissa = 0 %and
 1382+                    v_disp&16_FFFFFC0F = 16_00004000
 1383              %result = v_disp>>4&2_111 111
 1384           %finish
 1385        %finish
 1386        %result = -1
 1387     %end
 1388  
 1389     %routine  OPERAND (%record(stackfm) %name v)
 1390        %integer  base, disp, abase, mod
 1391        %integer  index, size, val, err
 1392        %switch  f (constant : a in rec)
 1393  
 1394        monitor (v, "Operand") %if diag&128 # 0
 1395        mod = 0
 1396        disp = v_disp
 1397        abase = v_base
 1398        abort (28) %if v_form = v in r %and
 1399+                      (abase = pc %or abase = fp %or abase = ap)
 1400        %if abase = local %start
 1401           abase = fp
 1402           abase = ap %and disp = disp - 60 %if disp > 0;  !parameter
 1403        %finish
 1404        abort (1) %if abase = 0 %and v_form # constant %and v_form # v in s
 1405        abort (2) %if v_oper # 0
 1406        base = actual reg(abase)
 1407        entry mask = entry mask ! regmask(abase) %if v_form = v in r
 1408        %if v_flags&indexed # 0 %start
 1409           index = v_index
 1410           abort (27) %if index = 0 %or index = pc %or
 1411+                         index = v_base %or v_form # v in s
 1412           %if v_flags&xdefer # 0 %start; ! @base[index]
 1413              abort (27) %if base < 0
 1414              base = base ! 16
 1415           %finish
 1416           put number byte (16_40+index-1)
 1417           release (index!128)
 1418        %finish
 1419        -> f (v_form)
 1420  
 1421     f(constant):
 1422        val = short literal (v)
 1423        %if val >= 0 %start;               ! short literal
 1424           put number byte (val)
 1425        %else %if v_type&real bit # 0
 1426           put number byte (16_8f)
 1427           longword (disp)
 1428           longword (v_mantissa) %if v_type = reall
 1429        %else;                             !use immediate
 1430           put number byte (16_8F);        !(pc)+
 1431           %unless fits (disp, v_type) %start
 1432              err = '*'
 1433              err = '?' %if control&ovf check = 0;   ! Warn only
 1434              error (err, "value " . itos(disp,0) . " overflows " . %c
 1435+                         type str(v_type&(integers+7), 15))
 1436           %finish
 1437           %if v_type = integers %start
 1438              longword (disp)
 1439           %else %if v_type = short+integers
 1440              word (disp)
 1441           %else %if v_type = byte+integers
 1442              put number byte (disp)
 1443           %finish
 1444        %finish
 1445        %return
 1446  
 1447     f(v in r):
 1448        put number byte (16_50+base);      ! register
 1449        %return
 1450  
 1451     f(a in s):
 1452        base = base ! 16;                  ! to overflow into mode field
 1453     f(v in s):
 1454        %if base < 0 %start;               ! %const<*>%name, object(const adr)
 1455           put number byte (16_9f);        !@#
 1456           longword (disp)
 1457           %return
 1458        %finish
 1459        release (v_base)
 1460        %if v_xno # 0 %start
 1461            flush code
 1462            put (obj ext ref)
 1463            put word (v_xno);  put long (disp);  ca = ca + 5
 1464            put (base)
 1465            %return
 1466         %finish
 1467         ! check if param of higher level
 1468         %if r6 <= abase <= r9 %and disp > 60 %and abase < local %start
 1469            flush code
 1470            put (obj modd)
 1471            mod = 1
 1472         %finish
 1473         size = msize (disp)
 1474         %if size <= 1 %start;                     !byte displacement
 1475            %if disp = 0 %and base&16 = 0 %start;   !register deferred
 1476               %if v_flags&auto d # 0 %start
 1477                  put number byte (16_70+base)
 1478               %else %if v_flags&auto i # 0
 1479                  put number byte (16_80+base)
 1480               %else
 1481                  put number byte (16_60+base)
 1482               %finish
 1483            %else
 1484               put number byte (16_A0+base)
 1485               put number byte (disp)
 1486            %finish
 1487         %else %if size = 2
 1488            put number byte (16_c0+base)
 1489            word (disp)
 1490         %else
 1491            put number byte (16_e0+base)
 1492            longword (disp)
 1493         %finish
 1494         flush code %if mod # 0
 1495         %return
 1496  
 1497     f(*):abort (13)
 1498     %end
 1499  
 1500     %routine  REMOVE (%record(stackfm) %name v)
 1501        release (v_base) %if v_form # v in r
 1502        release (v_index!128) %if v_flags&indexed # 0
 1503     %end
 1504  
 1505     %predicate  NEGATIVE (%record(stackfm) %name v)
 1506        %false %if v_form # constant
 1507        %if v_type&real bit # 0 %start
 1508           %false %unless v_disp&16_8000 # 0
 1509           v_lrval = -v_lrval
 1510        %else
 1511           %false %if v_disp = 16_80000000
 1512           %false %unless v_disp < 0
 1513           v_disp = -v_disp
 1514        %finish
 1515        %true
 1516     %end
 1517  
 1518     %routine  TEST ASSIGNED (%record(stackfm) %name v)
 1519        %integer op, old d
 1520        %return %if v_form = constant %or v_form = v in r %or
 1521+                   v_base = gla      %or v_xno # 0
 1522        v_form = v in r %if v_form = 255;       !special from plant2
 1523        %return %if control&ass check = 0
 1524        %if v_type = reall %then op = cmpd&255 %else op = cmpl&255
 1525        op = cmpw&255 %if v_type = strings
 1526        %return %if v_base = local %and
 1527+                  ((v_disp > 0 %and v_form # a in s) %or v_disp < last local)
 1528        old d = diag;  diag = 0;    ! Don't monitor anything here
 1529        put code (opcode(op))
 1530        operand (v);  claim (v_base) %unless v_form = v in r
 1531        claim (v_index!128) %if v_flags&indexed # 0
 1532        put number byte (16_60+gla-1);        !(gla)
 1533        diag = old d
 1534        prim (test ass)
 1535     %end
 1536  
 1537     %routine  CHECK INDIRECT (%record(stackfm) %name v)
 1538        %integer  save
 1539        %return %if control&ass check = 0
 1540        %if v_form = v in s %and
 1541+           v_flags&(indexed!xdefer) = indexed!xdefer %start
 1542           save = v_flags;   v_flags = 0
 1543           test assigned (v)
 1544           v_flags = save
 1545        %else %if v_form = a in s
 1546           save = v_type;  v_type = integers;  v_form = v in s
 1547           test assigned (v)
 1548           v_type = save;  v_form = a in s
 1549        %finish
 1550     %end
 1551  
 1552     %routine  PLANT1 (%integer op, %record(stackfm) %name v)
 1553        op = opcode(op&255)
 1554        %if control&ass check # 0 %start
 1555           check indirect (v)
 1556           test assigned (v) %if operand bits(op)&check1 # 0
 1557        %finish
 1558        put code (op);  operand (v)
 1559     %end
 1560  
 1561     %routine %spec  PLANT3 (%integer op, %record(stack fm) %name v1, v2, v3)
 1562     %routine  PLANT2 (%integer op, %record(stackfm) %name v1, v2)
 1563        %integer  bits, negflag
 1564        %record(stackfm)  work
 1565        %record(stack fm) %name  temp
 1566        %if op&addr bit # 0 %and v1_base # pc %and v1_form = v in s %and
 1567+           v1_flags&indexed = 0 %start
 1568           ! MOVAx_k(Rn),Y
 1569           %if v1_disp = 0 %start
 1570              ! MOVAx_(Rn),Y  ->  MOVL_Rn,Y : twice as fast!!
 1571              work = v1;  v1 == work
 1572              v1_form = v in r;  op = op&(\7) - 1*8
 1573              release (v1_base);   ! OPERAND doesn't in this case...
 1574           %else %if -63 <= v1_disp <= 63 %and
 1575+                    (v1_disp < 0 %or v1_base # local)
 1576              ! MOVAx_S(Rn),Y -> ADDL3_Rn,#S,Y  where s is short lit, and
 1577              ! not a parameter!!!!
 1578              work = 0;  work_disp = v1_disp;  work_type = integers
 1579              plant3 (addl+three op, regv(v1_base), work, v2)
 1580              release (v1_base)
 1581              %return
 1582           %finish
 1583        %finish
 1584        negflag = 0
 1585        negflag = 1 %if v1_type&integers#0 %and v1_form = constant %and
 1586+                       -64 <= v1_disp < 0
 1587        %if op&one bit # 0 %start;           !has 1-op variant
 1588           %if v2 == spv %start;             !-(sp)
 1589              %if op&addr bit # 0 %or
 1590+                 (op = movl %and negflag = 0) %start;  ! pusha, pushl
 1591                 op = op+8*3
 1592                 plant1 (op, v1);  %return
 1593              %finish
 1594           %finish
 1595           %if v1_form = constant %start
 1596              %if op&move bit # 0 %start
 1597                 %if zero (v1) %and v2_form # v in r %start
 1598                    !  mov #0  -> clr, except when dest a register!!!
 1599                    plant1 (op+8*5, v2)
 1600                    %return
 1601                 %else %if negflag # 0 %and v1_type # byte+integers
 1602                    %if v1_disp = -64 %start
 1603                       v1_disp = \v1_disp;       ! movx #-64 -> mcomx #63
 1604                       op = op + 8*2
 1605                    %else
 1606                       v1_disp = -v1_disp
 1607                       op = op - 8*1;            ! movx #-n -> mnegl #n
 1608                    %finish
 1609                 %finish
 1610              %finish
 1611              %if op&(add bit!sub bit) # 0 %start
 1612                 op = op!!(8!add bit!sub bit!commute) %if negative (v1)
 1613                 %if v1_type&integers # 0 %and v1_disp = 1 %and
 1614+                    v2_form # v in r %start
 1615                    ! add -> inc, except when dest reg...
 1616                    plant1 (op-8*2, v2)
 1617                    %return
 1618                 %finish
 1619              %finish
 1620           %finish
 1621        %finish
 1622        %if op&reversible # 0 %and short literal (v1) >= 0 %start
 1623           ! If possible, make a short literal the 2nd operand,
 1624           ! for pipelining speed gain.
 1625           temp == v1;   v1 == v2;   v2 == temp
 1626        %finish
 1627        op = opcode(op&255)
 1628        bits = operand bits(op)
 1629        check indirect (v1) %if control&ass check # 0
 1630        %if bits&move check = 0 %or v2_form # v in r %start
 1631           %if control&ass check # 0 %start
 1632              test assigned (v1) %if bits&check1 # 0
 1633              check indirect (v2)
 1634              test assigned (v2) %if bits&check2 # 0
 1635           %finish
 1636           put code (op)
 1637           operand (v1)
 1638           operand (v2)
 1639        %else
 1640           put code (op)
 1641           operand (v1)
 1642           operand (v2)
 1643           %if (v1_type = integers %or v1_type&real bit # 0) %andc
 1644+              (v1_form = a in s %or
 1645+               (v1_form = v in s %and
 1646+                (v1_base # local %or
 1647+                 v1_disp >= last local))) %start
 1648              v2_form = 255;                        !**special**
 1649              test assigned (v2)
 1650           %finish
 1651        %finish
 1652     %end
 1653  
 1654     %routine  PLANT3 (%integer op, %record(stackfm) %name v1, v2, v3)
 1655        %integer bits
 1656        %record(stackfm) %name temp
 1657        %record(stackfm) work
 1658        %if op&commute # 0 %start
 1659           %if v2_form = constant %or same (v1, v3) %start
 1660              temp == v1;  v1 == v2;  v2 == temp
 1661           %finish
 1662        %finish
 1663        %if op&two bit # 0 %start
 1664           %if op&(add bit!sub bit) # 0 %start
 1665              op = op!!(8!add bit!sub bit!commute) %if negative (v1)
 1666              %if v3_type = integers %and v1_form = constant %and
 1667+                 %not 0 <= v1_disp <= 63 %and
 1668+                 v2_form = v in r %and v2_type&realbit = 0 %and
 1669+                 %not same (v2, v3) %start
 1670                 ! addl3_#n,Rm,X -> moval_n(Rm),X
 1671                 v1_disp = -v1_disp %if op&sub bit # 0
 1672                 work = v2
 1673                 work_form = v in s
 1674                 work_disp = v1_disp
 1675                 claim (v2_base);            ! will get released
 1676                 plant2 (moval, work, v3)
 1677                 %return
 1678              %finish
 1679           %finish
 1680           %if same (v2, v3) %start;      !can use two op form
 1681              remove (v2)
 1682              plant2 ((op-8*8)&(\commute), v1, v3)
 1683              %return
 1684           %finish
 1685        %finish
 1686        %if op&commute # 0 %and short literal (v1) >= 0 %start
 1687           ! Better to have short literal 2nd, for
 1688           ! pipelining effects
 1689           temp == v1;  v1 == v2;  v2 == temp
 1690        %finish
 1691        op = opcode(op&255)
 1692        bits = operand bits(op)
 1693        %if control&ass check # 0 %start
 1694           check indirect (v1);  test assigned (v1) %if bits&check1 # 0
 1695           check indirect (v2);  test assigned (v2) %if bits&check2 # 0
 1696           check indirect (v3);  test assigned (v3) %if bits&check3 # 0
 1697        %finish
 1698        put code (op)
 1699        operand (v1)
 1700        operand (v2)
 1701        operand (v3)
 1702     %end
 1703  
 1704     %routine  PLANT4 (%integer  op, %record(stackfm) %name  v1, v2, v3, v4)
 1705        %if control&ass check # 0 %start
 1706           check indirect (v1);  check indirect (v2)
 1707           check indirect (v3);  check indirect (v4)
 1708        %finish
 1709        put code (opcode(op&255))
 1710        operand (v1);  operand (v2)
 1711        operand (v3);  operand (v4)
 1712     %end
 1713  
 1714     %routine  PLANT5 (%integer  op, %record(stackfm) %name  v1, v2, v3, v4, v5)
 1715        %if control&ass check # 0 %start
 1716           check indirect (v1);  check indirect (v2);  check indirect (v3)
 1717           check indirect (v4);  check indirect (v5)
 1718        %finish
 1719        put code (opcode(op&255))
 1720        operand (v1);  operand (v2);  operand (v3)
 1721        operand (v4);  operand (v5)
 1722        entry mask = entry mask ! 16_3c
 1723     %end
 1724  
 1725     %routine  HAZARD STRINGS
 1726        %integer  reg
 1727        hazard (reg) %for reg = r0, 1, r5
 1728     %end
 1729  
 1730     %routine  IOVF OFF
 1731        ! prevent overflow trap
 1732        %if entry mask&iovf bit # 0 %and ivbit state # 0 %start
 1733           word (bicpsw vbit)
 1734           ivbit state = 0
 1735        %finish
 1736     %end
 1737  
 1738     %routine  IOVF ON
 1739        ! re-enable overflow trap if it should be on
 1740        %if entry mask&iovf bit # 0 %and ivbit state = 0 %start
 1741           word (bispsw vbit)
 1742           ivbit state = 1
 1743        %finish
 1744     %end
 1745  
 1746     %routine  STRING3 (%integer  op, %record(stackfm) %name  v1, v2, v3)
 1747        %integer  code, stype, no check v2, old control = control
 1748        no check v2 = op&no ass chk
 1749        op = op & (\no ass chk)
 1750        code = 0
 1751        %if v1_form = constant %start
 1752           v1_type = short+integers
 1753           %if op = 0 %or op = movc3 %start; !look for short form
 1754              stype = scale type (v1_disp)
 1755              code = movl+stype %if stype >= 0
 1756           %finish
 1757        %finish
 1758        op = op & (\no short)
 1759        %if code = 0 %start;            ! character op required
 1760           release (v1_base);  release (v2_base);  release (v3_base)
 1761           hazard strings
 1762           claim (v1_base);  claim (v2_base);  claim (v3_base)
 1763        %finish
 1764        %if control&ass check # 0 %start
 1765           %if no check v2 = 0 %start
 1766              check indirect (v2)
 1767              test assigned (v2)
 1768           %finish
 1769           check indirect (v3)
 1770           test assigned (v3) %if op = cmpc3
 1771           control = control & (\ass check)
 1772        %finish
 1773        %if op = 0 %start;              !concat
 1774           op = movc3
 1775           v2_disp = v2_disp + 1;       !skip the length
 1776        %finish
 1777        %if code # 0 %start
 1778           %if v3_base = r3 %and v3_disp = 0 %and
 1779+              v3_form = v in s %and v3_flags = 0 = v3_xno %start
 1780              v3_flags = auto i
 1781              op = 0
 1782           %finish
 1783           plant2 (code, v2, v3)
 1784           last movc3 = ca %and v3_flags = 0 %if op = 0
 1785        %else
 1786           entry mask = entry mask ! 16_3C;    ! R0:R5 used
 1787           plant3 (op, v1, v2, v3)
 1788           last movc3 = ca %if op = movc3
 1789        %finish
 1790        control = old control
 1791     %end
 1792  
 1793  !   %routine  STRING5 (%integer  op,
 1794  !                      %record(stackfm) %name  v1, v2, v3, v4, v5)
 1795  !      release (v1_base)
 1796  !      release (v2_base)
 1797  !      release (v3_base)
 1798  !      release (v4_base)
 1799  !      release (v5_base)
 1800  !      hazard strings
 1801  !      claim (v1_base)
 1802  !      claim (v2_base)
 1803  !      claim (v3_base)
 1804  !      claim (v4_base)
 1805  !      claim (v5_base)
 1806  !      entry mask = entry mask ! 16_3c
 1807  !      plant5 (op, v1, v2, v3, v4, v5)
 1808  !   %end
 1809  
 1810     %routine  PRIM EP (%integer n)
 1811        %integer  ep
 1812        %own %byte %array  prim eps (1 : prim rts) = 0(*)
 1813        ep = prim eps(n)
 1814        %if ep = 0 %start;            !first use
 1815           prim eps(n) = 1
 1816           put (obj prim spec);  put (n)
 1817        %finish
 1818        entry mask = entry mask ! prim mask(n)
 1819     %end
 1820  
 1821     %routine  PRIM (%integer  n)
 1822        %integer  r
 1823        prim ep (n)
 1824        %if test ass # n # test string ovf %start
 1825           hazard (r) %for r = r0, 1, r5
 1826        %finish
 1827        flush code;  set line
 1828        put (obj prim ref);  put (n);  ca = ca + 6
 1829     %end
 1830  
 1831     %routine  DUMP TEXT (%string(*) %name  text)
 1832        %integer  p, sym
 1833        length(text) = max ident %if length(text) > max ident
 1834        %for p = 0, 1, length(text) %cycle
 1835           sym = charno(text, p)
 1836           sym = sym-32 %if 'a' <= sym <= 'z'
 1837           put (sym)
 1838        %repeat
 1839     %end
 1840  
 1841     %routine  LPUT (%integer  ep, addr)
 1842        put (ep)
 1843        put long (addr)
 1844        dump text (external name)
 1845     %end
 1846  
 1847     %routine  DEFINE TAG (%integer  ref)
 1848        select output tank (directives)
 1849        put (dir ldef)
 1850        put word (ref);  put long (ca)
 1851        select output tank (object)
 1852     %end
 1853  
 1854     %routine  DEFINE ENTRY (%integer ref)
 1855        select output tank (directives)
 1856        put (dir entry);   put word (ref)
 1857        select output tank (object)
 1858     %end
 1859  
 1860     %routine  DEFINE REFERENCE (%integer ref, type)
 1861        select output tank (directives)
 1862        put (type)
 1863        last ref = ref
 1864        put word (ref);  put long (ca)
 1865        select output tank (object)
 1866     %end
 1867  
 1868  !register handling routines
 1869  
 1870     %routine  CLAIM (%integer reg)
 1871        !cherish the value in the register
 1872        %string(2) s = ""
 1873        %integer j
 1874        %if reg&128 # 0 %start;    ! Claimed as index
 1875           reg = reg & 127
 1876           index regs = index regs + 1
 1877           abort (40) %unless activity(reg) >= 0 %and r0 <= reg <= r10
 1878           indx(reg) = indx(reg) + 1
 1879           s = "[]"
 1880        %finish
 1881        %return %if reg = 0 %or activity(reg) < 0;   !none or locked
 1882        mon reg ("Claim".s, reg) %if diag&4 # 0
 1883        active regs = active regs+1;                 !one more active
 1884        activity(reg) = activity(reg)+1;             !note claimed
 1885        used(reg) = ca;                              !and note when used last
 1886        %if reg >= fpr0 %start;                      !claim general equivs
 1887           reg = (reg-fpr0)<<1+r0
 1888           j = diag; diag = 0
 1889           claim (reg);  claim (reg+1)
 1890           diag = j
 1891        %finish
 1892     %end
 1893  
 1894     %routine  RELEASE (%integer reg)
 1895        ! hazard the value in a register
 1896        %integer old d
 1897        %string(2) s = ""
 1898        %if reg&128 # 0 %start
 1899           reg = reg&127
 1900           abort (41) %unless r0 <= reg <= r10
 1901           abort (42) %if activity(reg) < 0
 1902           index regs = index regs - 1
 1903           abort (43) %if index regs < 0
 1904           indx(reg) = indx(reg) - 1
 1905           abort (44) %if indx(reg) < 0
 1906           s = "[]"
 1907        %finish
 1908        %return %if reg = 0 %or activity(reg) < 0;   !none or locked
 1909        mon reg ("Release".s, reg) %if diag&4 # 0
 1910        active regs = active regs - 1;               !one less active
 1911        activity(reg) = activity(reg) - 1;           !one less user
 1912        abort (3) %if activity(reg) < 0;             !too many
 1913        %if reg >= fpr0 %start
 1914           reg = (reg-fpr0)<<1+r0
 1915           old d = diag;  diag = 0
 1916           release (reg);  release (reg+1)
 1917           diag = old d
 1918        %finish
 1919     %end
 1920  
 1921     %routine  CLEAR (%record(stackfm) %name  v)
 1922        monitor (v, "Clear") %if diag&4 # 0
 1923        release (v_base) %if v_form = v in r
 1924     %end
 1925  
 1926     %routine  SCALE INDEX (%integername op, %record(stackfm) %name v)
 1927        ! Ensure that array elements are scaled correctly when
 1928        ! the address of one is required (the descriptor will normally
 1929        ! look like an integer at this stage!)
 1930        %integer type
 1931        %return %if op&addr bit = 0 %or v_flags&indexed = 0
 1932        monitor (v, "Scale index") %if diag&128 # 0
 1933        type = scale type (v_iscale)
 1934        abort(35) %if type < 0
 1935        op = (op&(\7)) ! type
 1936     %end
 1937  
 1938     %routine  HAZARD (%integer  reg)
 1939        ! protect the value in register 'reg' by storing in a temp
 1940        %integer n, op, r, form
 1941        %record(dfm) %name p
 1942        %record(stackfm) temp
 1943        %record(stackfm) %name s
 1944  
 1945        %routine  MOD (%record(stackfm) %name  v)
 1946           %switch  s (constant : a in rec)
 1947           n = n - 1
 1948           active regs = active regs - 1
 1949           monitor (v, "Hazard") %if diag&4 # 0
 1950           -> s(v_form&7)
 1951        s(constant):
 1952        s(v in rec):
 1953        s(avin rec):
 1954        s(a in rec):
 1955           abort (4)
 1956        s(v in s):
 1957        s(avin s):
 1958        s(a in s):
 1959           v_form = v_form+3;  v_extra = temp_disp;  v_base = local
 1960           %return
 1961        s(v in r):
 1962           v_form = v in s;  v_disp = temp_disp;  v_base = local
 1963        %end
 1964  
 1965        %routine  SET TEMP (%integer size)
 1966           frame = frame-(size)&(\(size-1))
 1967           temp = 0
 1968           temp_base = local;  temp_disp = frame
 1969           temp_type = integers;  temp_form = v in s
 1970           op = movl; op = movd %if size = 8
 1971        %end
 1972  
 1973        mon reg ("Hazard", reg) %if diag&4 # 0
 1974        n = activity(reg)
 1975        %if n <= 0 %start
 1976           %return %if reg < fpr0
 1977           reg = (reg-fpr0)<<1+r0
 1978           hazard (reg);  hazard (reg+1)
 1979           %return
 1980        %finish
 1981        %if indx(reg) # 0 %start;     ! Reg in use as index
 1982           p == using_link
 1983           %while p ## null %cycle
 1984              s == p_d
 1985              %if s_flags&indexed # 0 %and s_index = reg %start
 1986                 set temp (4)
 1987                 op = moval;  scale index (op, s)
 1988                 form = s_form+3;  s_form = v in s
 1989                 plant2 (op, s, temp)
 1990                 s_flags = 0; s_form = form;  s_disp = 0
 1991                 s_base = local;  s_extra = temp_disp
 1992              %finish
 1993              p == p_link
 1994           %repeat
 1995           abort (31) %if indx(reg) # 0
 1996           abort (5) %if activity(reg) # 0
 1997           %return
 1998        %finish
 1999        activity(reg) = 0
 2000        %if reg >= fpr0 %start
 2001           r = (reg-fpr0)<<1+r0
 2002           activity(r) = 0;  activity(r+1) = 0
 2003           active regs = active regs-n-n
 2004           set temp (8)
 2005        %else
 2006           %if reg <= r5 %start;            !check fpr equivs
 2007              r = (reg-r0)>>1+fpr0
 2008              %if activity(r) > 0 %start
 2009                 hazard (r);  %return
 2010              %finish
 2011           %finish
 2012           set temp (4)
 2013        %finish
 2014        plant2 (op, regv(reg), temp)
 2015  
 2016        p == using_link
 2017        %while p ## null %cycle
 2018           mod (p_d) %if p_d_base = reg
 2019           p == p_link
 2020        %repeat
 2021        abort (5) %if n # 0
 2022     %end
 2023  
 2024     %integer %function  REGISTER (%integer  pair)
 2025        !returns a suitable register
 2026        %integer r
 2027        %integer worstn, worstr, worstu
 2028  
 2029        worstn = 100; worstu = ca
 2030  
 2031        %for r = r10, -1, r1 %cycle
 2032           %if activity(r) = 0 = activity(r+pair) %start;     !not being used
 2033              used(r) = ca;  %result = r
 2034           %else %if 0 < activity(r) < worstn
 2035              worstn = activity(r);  worstr = r
 2036              worstu = used(r)
 2037           %else %if activity(r) = worstn %and used(r) < worstu
 2038              worstr = r;  worstu = used(r)
 2039           %finish
 2040        %repeat
 2041  
 2042        hazard (worstr)
 2043        used(worstr) = ca
 2044        %result = worstr
 2045     %end
 2046  
 2047     %integer %function  FPR
 2048        %own %integer next = fpr4+1
 2049        %result = fpr0 %if activity(r0) = 0 = activity(r1)
 2050        %result = fpr2 %if activity(r2) = 0 = activity(r3)
 2051        %result = fpr4 %if activity(r4) = 0 = activity(r5)
 2052        next = fpr4+1 %if next = fpr0
 2053        next = next-1
 2054        hazard (next)
 2055        %result = next
 2056     %end
 2057  
 2058  !descriptor processing
 2059  
 2060     %record(stackfm) %map  DESCRIPTOR
 2061        %record(dfm) %name d
 2062        %record(stackfm) %name v
 2063        v == desc asl;  abort (6) %if v == null
 2064        d == d asl;     abort (7) %if d == null
 2065        desc asl == v_link;  v = 0;  v_link == null
 2066        d asl == d_link
 2067        d_link == using_link
 2068        using_link == d
 2069        d_d == v
 2070        abort (8) %if stp >= max depth
 2071        stp = stp + 1
 2072        stacked(stp) == v
 2073        %result == v
 2074     %end
 2075  
 2076     %routine  DROP (%record(stackfm) %name d)
 2077        %record(dfm) %name  p, q
 2078        monitor (d, "Drop") %if diag&1 # 0
 2079        p == using
 2080        %cycle
 2081           q == p_link
 2082           abort (9) %if q == null
 2083           %exit %if q_d == d
 2084           p == q
 2085        %repeat
 2086        p_link == q_link
 2087        q_link == d asl
 2088        d asl == q
 2089        d_link == desc asl
 2090        desc asl == d
 2091     %end
 2092  
 2093     %routine  VSTACK (%record(varfm) %name v)
 2094        %record(stackfm) %name  x
 2095        x == descriptor
 2096        x_type     = v_type
 2097        x_form     = v_form&(15!arrayname bit!proc bit)
 2098        x_base     = v_base
 2099        x_disp     = v_disp
 2100        x_format   = v_format
 2101        x_extra    = v_extra
 2102        x_length   = v_length
 2103        x_header   = v_header
 2104        x_mantissa = v_zeroad;                  ! Zero-address for C-B arrays
 2105        x_mantissa = v_flags %if v_flags # 0;   ! or prim index
 2106        x_xno      = v_xno
 2107        monitor (x, "Vstack") %if diag&1 # 0
 2108     %end
 2109  
 2110     %routine  DSTACK (%record(stackfm) %name v)
 2111        %record(stackfm) %name t
 2112        t == descriptor
 2113        t = v
 2114        monitor (t, "Dstack") %if diag&1 # 0
 2115     %end
 2116  
 2117     %routine  GET REAL
 2118        %long %real  p, val
 2119        %record(stackfm) %name v
 2120        %integer n, s
 2121        %on 1 %start;        ! real overflow!
 2122           error ('*', "real value too large")
 2123           val = 0;  -> out
 2124        %finish
 2125        n = getword;  get (discard)
 2126        val = 0
 2127        %cycle
 2128           get (s)
 2129           -> power %if s = '@'
 2130           %exit %if s = '.'
 2131           val = val*10+(s-'0')
 2132           n = n-1
 2133           -> out %if n = 0
 2134        %repeat
 2135        p = 1
 2136        %cycle
 2137           n = n - 1;  -> out %if n = 0
 2138           get (s)
 2139           -> power %if s = '@'
 2140           p = p/10
 2141           val = val + (s-'0')*p
 2142        %repeat
 2143     power:
 2144        n = getword;           ! Was GETLONG!!!!
 2145        val = val*10\n
 2146     out:
 2147        v == descriptor
 2148        v_type = reall;  v_form = constant
 2149        v_lrval = val
 2150     %end
 2151  
 2152     %routine  CSTACK (%integer value)
 2153        %record(stackfm) %name v
 2154        v == descriptor
 2155        v_disp = value
 2156        v_type = integers
 2157        v_form = constant
 2158        monitor (v, "Cstack") %if diag&1 # 0
 2159     %end
 2160  
 2161     %routine  LSTACK (%integer disp)
 2162        %record(stackfm) %name  v
 2163        v == descriptor
 2164        v_disp = disp
 2165        v_base = local
 2166        v_type = integers
 2167        v_form = v in s
 2168        monitor (v, "Lstack") %if diag&1 # 0
 2169        lhs == v
 2170     %end
 2171  
 2172     %record(stackfm) %map  TEMP (%integer size)
 2173        %record(stackfm) %name d
 2174        d == descriptor
 2175        frame = (frame-size)&(\3)
 2176        d_base = local;  d_disp = frame
 2177        d_type = integers;  d_form = v in s
 2178        %result == d
 2179     %end
 2180  
 2181     %record(stackfm) %map  LITERAL (%integer n)
 2182        %record(stackfm) %name d
 2183        d == descriptor
 2184        d_base = 0;  d_disp = n
 2185        d_type = integers;  d_form = constant
 2186        %result == d
 2187     %end
 2188  
 2189     %routine  SET LHS
 2190        lhs == stacked(stp)
 2191        monitor (lhs, "Set lhs") %if diag&1 # 0
 2192     %end
 2193  
 2194     %routine  SET BOTH
 2195        abort (10) %if stp <= 1
 2196        lhs == stacked(stp-1)
 2197        rhs == stacked(stp  )
 2198        %if diag&1 # 0 %start
 2199           monitor (lhs, "Both lhs")
 2200           monitor (rhs, "     rhs")
 2201        %finish
 2202     %end
 2203  
 2204     %routine  POP LHS
 2205        abort (11) %if stp <= 0
 2206        stp = stp - 1
 2207        lhs == stacked(stp+1)
 2208        monitor (lhs, "Pop lhs") %if diag&1 # 0
 2209     %end
 2210  
 2211     %routine  POP DROP
 2212        %integer  d
 2213        %record(stack fm) %name  t
 2214        abort (12) %if stp <= 0
 2215        stp = stp - 1
 2216        t == stacked(stp+1)
 2217        monitor (t, "Pop drop") %if diag&1 # 0
 2218        d = diag;  diag = 0;  drop (t);  diag = d
 2219     %end
 2220  
 2221     %routine  MACHINE CODE
 2222        %integer  sym, n, j
 2223        %integer  opcode, operands, flags
 2224        %string(6)  optext
 2225  
 2226        %const %integer %array  code (0 : 511) =
 2227+          16_871238F1,16_F360015B, 16_87123AB3,16_F260015B,
 2228+          16_88B2CAB7,16_B9200002, 16_88BACAB7,16_B8200002,
 2229+          16_8B8B50CC,16_6B40001C, 16_8B8B510C,16_4B40001B,
 2230+          16_8E65DA43,16_3880024A, 16_970ACEE5,16_0E400019,
 2231+          16_9C6916D8,16_06000000, 16_9E3B1543,16_3980028A,
 2232+          16_9F1C4AAC,16_DC200003, 16_9F1C5AE3,16_2FC0A24A,
 2233+          16_9F1C708C,16_9A400019, 16_9F1C7097,16_9B400011,
 2234+          16_9F1C732C,16_3C40001A, 16_A54890F2,16_0C600051,
 2235+          16_A54890F7,16_0D600051, 16_A57AA862,16_9F200001,
 2236+          16_A57AA86C,16_DF200003, 16_A57AA871,16_7F200004,
 2237+          16_A57AA877,16_3F200002, 16_A877CEE5,16_0F400019,
 2238+          16_AB1224F1,16_F440002B, 16_AB1226D2,16_F540002B,
 2239+          16_AB8916D8,16_07000000, 16_00000000,16_00000000,
 2240+          16_00000000,16_00000000, 16_00000000,16_00000000,
 2241+          16_00000000,16_00000000, 16_00000000,16_00000000,
 2242+          16_00000000,16_00000000, 16_00000000,16_00000000,
 2243+          16_00000000,16_00000000, 16_00000000,16_00000000,
 2244+          16_00000000,16_00000000, 16_00000000,16_00000000,
 2245+          16_00000000,16_00000000, 16_00000000,16_00000000,
 2246+          16_00011083,16_E160014B, 16_00011093,16_E060014B,
 2247+          16_00011254,16_03000000, 16_00011282,16_11200005,
 2248+          16_00011297,16_31200006, 16_00011303,16_1C200005,
 2249+          16_00011313,16_1D200005, 16_00011683,16_0BA03299,
 2250+          16_00012103,16_EB80064B, 16_00012113,16_EA80064B,
 2251+          16_000131F0,16_17200001, 16_000132A2,16_16200001,
 2252+          16_00014230,16_01000000, 16_000150E9,16_02000000,
 2253+          16_000150F4,16_04000000, 16_000152A2,16_05000000,
 2254+          16_00016903,16_FC000000, 16_00219482,16_9D800C49,
 2255+          16_00219484,16_6F800D24, 16_00219486,16_4F800CDB,
 2256+          16_0021948C,16_F1800CDB, 16_00219497,16_3D800C92,
 2257+          16_00219B23,16_D840001B, 16_0021D54C,16_786000D9,
 2258+          16_0021D550,16_F8C0A251, 16_0021D551,16_79600121,
 2259+          16_002210A3,16_E560014B, 16_002210B3,16_E360014B,
 2260+          16_002212A3,16_E460014B, 16_002212B3,16_E260014B,
 2261+          16_00221E6C,16_13200005, 16_002224F1,16_18200005,
 2262+          16_002226D2,16_14200005, 16_00222EC2,16_93400009,
 2263+          16_00222ECC,16_D340001B, 16_00222ED7,16_B3400012,
 2264+          16_00223883,16_E940002B, 16_00223893,16_E840002B,
 2265+          16_002238F1,16_15200005, 16_00223AB3,16_19200005,
 2266+          16_002240F1,16_12200005, 16_00225482,16_10200005,
 2267+          16_00225497,16_30200006, 16_0022A9E5,16_BD200002,
 2268+          16_0022A9EB,16_BC200002, 16_0022A9F3,16_BE200002,
 2269+          16_0022A9F5,16_BF200002, 16_0022BA82,16_94200001,
 2270+          16_0022BA8C,16_D4200003, 16_0022BA91,16_7C200004,
 2271+          16_0022BA97,16_B4200002, 16_0022BE42,16_91400009,
 2272+          16_0022BE44,16_71400024, 16_0022BE46,16_5140001B,
 2273+          16_0022BE4C,16_D140001B, 16_0022BE56,16_EC80064B,
 2274+          16_0022BE57,16_B1400012, 16_00231CA2,16_97200001,
 2275+          16_00231CAC,16_D7200003, 16_00231CB7,16_B7200002,
 2276+          16_00232F10,16_27C0A28A, 16_00239976,16_7B8006E3,
 2277+          16_0023BEEC,16_7A8008DB, 16_0023EAD6,16_EE80064B,
 2278+          16_00250DD4,16_00000000, 16_0025C0A2,16_96200001,
 2279+          16_0025C0AC,16_D6200003, 16_0025C0B7,16_B6200002,
 2280+          16_0025C2B6,16_F080025B, 16_002744A3,16_3A600051,
 2281+          16_0027A252,16_DB40001B, 16_0027C702,16_90400009,
 2282+          16_0027C704,16_70400024, 16_0027C706,16_5040001B,
 2283+          16_0027C70C,16_D040001B, 16_0027C710,16_3460004A,
 2284+          16_0027C711,16_7D400024, 16_0027C717,16_B0400012,
 2285+          16_0027DA52,16_DA40001B, 16_0027DDD0,16_25C0A28A,
 2286+          16_00294652,16_BA200002, 16_002A46CC,16_9C6000D9,
 2287+          16_002A9323,16_D940001B, 16_002AB643,16_3B600051,
 2288+          16_002B56C2,16_95200001, 16_002B56C4,16_73200004,
 2289+          16_002B56C6,16_53200003, 16_002B56CC,16_D5200003,
 2290+          16_002B56D7,16_B5200002, 16_04330F29,16_58400012,
 2291+          16_04331872,16_80400009, 16_04331873,16_81600049,
 2292+          16_043318B2,16_60400024, 16_043318B3,16_61600124,
 2293+          16_043318F2,16_4040001B, 16_043318F3,16_4140001B,
 2294+          16_043319B2,16_C040001B, 16_043319B3,16_C16000DB,
 2295+          16_04331A34,16_2080028A, 16_04331A36,16_21C0A28A,
 2296+          16_04331B12,16_A0400012, 16_04331B13,16_A1600092,
 2297+          16_044214A9,16_E760014B, 16_044256A9,16_E660014B,
 2298+          16_04449E75,16_1E200005, 16_0444DA95,16_1A200005,
 2299+          16_04459472,16_8A400009, 16_04459473,16_8B600049,
 2300+          16_044595B2,16_CA40001B, 16_044595B3,16_CB6000DB,
 2301+          16_04459712,16_AA400012, 16_04459713,16_AB600092,
 2302+          16_0445D472,16_88400009, 16_0445D5B2,16_C840001B,
 2303+          16_0445D5B3,16_C96000DB, 16_0445D712,16_A8400012,
 2304+          16_0445D713,16_A9600092, 16_04471E75,16_1B200005,
 2305+          16_044756B5,16_1F200005, 16_0451B9C7,16_FA400009,
 2306+          16_0451B9D3,16_FB40000B, 16_0451D4E2,16_8F600049,
 2307+          16_0451D4EC,16_CF6000DB, 16_0451D4F7,16_AF600092,
 2308+          16_0457C893,16_2960004A, 16_0457C895,16_2DA0144A,
 2309+          16_0457CA34,16_3780028A, 16_0457CB96,16_ED80064B,
 2310+          16_0458BE33,16_3560004A, 16_045C5884,16_6C400021,
 2311+          16_045C5886,16_4C400019, 16_045C588C,16_98400019,
 2312+          16_045C5897,16_99400011, 16_045C58C2,16_6840000C,
 2313+          16_045C58C6,16_7640001C, 16_045C58CC,16_6A40001C,
 2314+          16_045C58D7,16_69400014, 16_045C5902,16_4840000B,
 2315+          16_045C5904,16_56400023, 16_045C590C,16_4A40001B,
 2316+          16_045C5917,16_49400013, 16_045C59C2,16_F640000B,
 2317+          16_045C59C4,16_6E400023, 16_045C59C6,16_4E40001B,
 2318+          16_045C59D0,16_F9600053, 16_045C59D7,16_F7400013,
 2319+          16_045C5A4C,16_366000CA, 16_045C5A53,16_0880028A,
 2320+          16_045C5A54,16_24A0144A, 16_045C5AB0,16_0980028A,
 2321+          16_045C5AD0,16_26A0144A, 16_045C5B22,16_3340000A,
 2322+          16_045C5B24,16_6D40001A, 16_045C5B2C,16_3240001A,
 2323+          16_0463E072,16_86400009, 16_0465E073,16_87600049,
 2324+          16_0465E0B2,16_66400024, 16_0465E0B3,16_67600124,
 2325+          16_0465E0F2,16_4640001B, 16_0465E0F3,16_476000DB,
 2326+          16_0465E1B2,16_C640001B, 16_0465E1B3,16_C76000DB,
 2327+          16_0465E312,16_A6400012, 16_0465E313,16_A7600092,
 2328+          16_0477C4C4,16_74A0470C, 16_0477C4C6,16_54A036CB,
 2329+          16_047D5B96,16_EF80064B, 16_04B818F8,16_0AC1B6DB,
 2330+          16_04F2C5E2,16_92400009, 16_04F2C5EC,16_D240001B,
 2331+          16_04F2C5F7,16_B2400012, 16_04F5D473,16_89600049,
 2332+          16_04F81D22,16_8E400009, 16_04F81D24,16_72400024,
 2333+          16_04F81D26,16_5240001B, 16_04F81D2C,16_CE40001B,
 2334+          16_04F81D37,16_AE400012, 16_04F8E062,16_9E400019,
 2335+          16_04F8E06C,16_DE40001B, 16_04F8E071,16_7E40001C,
 2336+          16_04F8E077,16_3E40001A, 16_04F8E093,16_2860004A,
 2337+          16_04F8E095,16_2CA0144A, 16_04F8E2C3,16_2EC0A24A,
 2338+          16_04FBB872,16_84400009, 16_04FBB873,16_85600049,
 2339+          16_04FBB8B2,16_64400024, 16_04FBB8B3,16_65600124,
 2340+          16_04FBB8F2,16_4440001B, 16_04FBB8F3,16_456000DB,
 2341+          16_04FBB9B2,16_C440001B, 16_04FBB9B3,16_C56000DB,
 2342+          16_04FBBB12,16_A4400012, 16_04FBBB13,16_A5600092,
 2343+          16_0528BB64,16_75600054, 16_0528BB66,16_55600053,
 2344+          16_052BD54C,16_DD200003, 16_052BD552,16_BB200002,
 2345+          16_05528E03,16_2A80024A, 16_05590E03,16_2B80024A,
 2346+          16_055B9072,16_82400009, 16_055B9073,16_83600049,
 2347+          16_055B90B2,16_62400024, 16_055B90B3,16_63600124,
 2348+          16_055B90F2,16_4240001B, 16_055B90F3,16_436000DB,
 2349+          16_055B91B2,16_C240001B, 16_055B91B3,16_C36000DB,
 2350+          16_055B9234,16_2280028A, 16_055B9236,16_23C0A28A,
 2351+          16_055B9312,16_A2400012, 16_055B9313,16_A3600092,
 2352+          16_05A8D072,16_8C400009, 16_05A8D073,16_8D600049,
 2353+          16_05A8D1B2,16_CC40001B, 16_05A8D1B3,16_CD6000DB,
 2354+          16_05A8D312,16_AC400012, 16_05A8D313,16_AD600092
 2355  
 2356        %routine  MC ERROR (%string(23) text)
 2357           error ('*', optext.": ".text)
 2358           get (sym) %while sym # ';'
 2359        %end
 2360  
 2361        %integer %function  FIND (%integer key)
 2362           %integer a, b, p
 2363           a = 0;  b = 512
 2364           %while a <= b %cycle
 2365              p = (a+b)>>2<<1
 2366              %result = p %if code(p) = key
 2367              %if key > code(p) %then a = p+2 %else b = p-2
 2368           %repeat
 2369           %result = -1
 2370        %end
 2371  
 2372        %predicate  PARSED OPERAND (%integer flag)
 2373           %byte %array  oper (1 : 128)
 2374           %integer  base, disp, sign, indirect, m, p, size
 2375           %record(varfm) %name  v
 2376  
 2377           %predicate  LITERAL (%integername n)
 2378              %false %unless '0' <= sym <= '7'
 2379              n = 0
 2380              %cycle
 2381                 n = n<<3 + sym-'0'
 2382                 get (sym)
 2383                 %true %unless '0' <= sym <= '7'
 2384              %repeat
 2385           %end
 2386  
 2387           %predicate  REG (%integername r)
 2388              get (sym);        !skip (
 2389              %false %unless literal (r)
 2390              %false %unless 0 <= r <= 15
 2391              %false %if sym # ')'
 2392              get (sym)
 2393              %true
 2394           %end
 2395  
 2396           %routine  SET BYTE (%integer b)
 2397              p = p + 1;  oper(p) = b
 2398           %end
 2399  
 2400           %routine  SET WORD (%integer n)
 2401              shortinteger(addr(oper(p+1))) = n
 2402              p = p + 2
 2403           %end
 2404  
 2405           %routine  SET LONGWORD (%integer n)
 2406              integer(addr(oper(p+1))) = n
 2407              p = p + 4
 2408           %end
 2409  
 2410           p = 0
 2411           indirect = 0;  sign = 1
 2412  
 2413           entry mask = entry mask ! 16_ffc
 2414  
 2415           %if sym = '@' %and flag < 5 %start
 2416              indirect = 16_10;  get (sym)
 2417           %finish
 2418  
 2419           %if sym = '#' %start
 2420              get (sym)
 2421              sign = -1 %and get (sym) %if sym = '-'
 2422              %false %unless literal (disp)
 2423              disp = disp*sign
 2424              %if 0 <= disp <= 63 %and indirect = 0 %start
 2425                 set byte (disp);  ->ok
 2426              %finish
 2427              set byte (16_8F)
 2428              %if flag = 3 %or indirect # 0 %start
 2429                 set longword (disp);  ->ok
 2430              %finish
 2431              %if flag = 1 %or flag = 5 %start
 2432                 set byte (disp);  ->ok
 2433              %finish
 2434              %if flag = 2 %or flag = 6 %start
 2435                 set word (disp);  ->ok
 2436              %finish
 2437              set longword (disp);  set longword (0);  ->ok
 2438           %finish
 2439  
 2440           %if sym = '(' %start
 2441              %false %unless reg (base) %and flag < 5
 2442              disp = 0 %and -> basedisp %if indirect # 0
 2443              base = base+16_60
 2444              %if sym = '+' %start
 2445                 get (sym)
 2446                 base = base+16_20
 2447              %finish
 2448              set byte (base+indirect)
 2449              -> ok
 2450           %finish
 2451  
 2452           %if sym = ' ' %start;                !tag value
 2453              get (sym)
 2454              %false %unless literal(m)
 2455              v == var(m)
 2456              base = v_base
 2457              disp = v_disp
 2458              %if v_form = 15 %start;         !label
 2459                 flush code
 2460                 %if flag = 5 %start;         !byte disp
 2461                    put (obj b lab);  ca = ca+1
 2462                 %else %if flag = 6;          !word disp
 2463                    put (obj w lab);  ca = ca+2
 2464                 %else;                       !pc-rel
 2465                    define reference (disp, dir pref)
 2466                    put (obj call);  ca = ca + 2
 2467                    put long (disp)
 2468                    %true
 2469                 %finish
 2470                 put word (disp)
 2471                 %true
 2472              %finish
 2473              %if  base = local %start
 2474                 base = fp
 2475                 base = ap %and disp = disp-60 %if disp > 0
 2476              %finish
 2477              base = base-1
 2478              %if sym = '+' %or sym = '-' %start
 2479                 sign = sym
 2480                 get (sym)
 2481                 %false %unless literal (m)
 2482                 m = -m %if sign = '-'
 2483                 disp = disp+m
 2484              %finish
 2485     base disp:
 2486              base = base+indirect
 2487              size = msize (disp)
 2488              %if size <= 1 %start
 2489                 set byte (16_a0+base)
 2490                 set byte (disp)
 2491              %else %if size = 2
 2492                 set byte (16_c0+base)
 2493                 set word (disp)
 2494              %else
 2495                 set byte (16_e0+base)
 2496                 set longword (disp)
 2497              %finish
 2498              -> ok
 2499           %finish
 2500  
 2501           %if sym = '-' %and indirect = 0 %and flag < 5 %start
 2502              get (sym)
 2503              %if sym = '(' %start
 2504                 %false %unless reg (base)
 2505                 set byte (16_70+base)
 2506                 -> ok
 2507                 %finish
 2508              %false %unless literal (disp)
 2509              disp = -disp
 2510              -> bd
 2511           %finish
 2512  
 2513           %false %unless literal (disp) %and flag < 5
 2514     bd:   %if sym = '(' %start
 2515              %false %unless reg (base)
 2516              -> base disp
 2517           %finish
 2518           %false %unless 0 <= disp <= 15
 2519           set byte (16_50+disp)
 2520  
 2521     ok:   %if sym = '[' %and flag < 5 %start;            !indexed
 2522              get (sym)
 2523              %false %unless literal (base) %and sym = ']'
 2524              get (sym)
 2525              put number byte (16_40+base)
 2526           %finish
 2527           put number byte (oper(m)) %for m = 1, 1, p
 2528           %true
 2529        %end
 2530  
 2531        get (sym)
 2532        op text = "";  n = 0
 2533        %cycle
 2534           %exit %if sym = '_'
 2535           %if length(optext) # 6 %start
 2536              optext = optext . tostring(sym)
 2537              n = n<<5 + sym
 2538           %finish
 2539           get (sym)
 2540        %repeat
 2541        get (sym)
 2542        j = find (n)
 2543        %if j < 0 %start
 2544           mc error("Unknown opcode")
 2545           %return
 2546        %finish
 2547        flags = code(j+1)
 2548        opcode = flags>>24
 2549        operands = flags>>21&7
 2550        put code (opcode)
 2551        %if operands > 0 %start
 2552           %cycle
 2553              %unless parsed operand (flags&7) %start
 2554                 mc error ("Bad operand")
 2555                 %return
 2556              %finish
 2557              flags = flags>>3
 2558              operands = operands-1
 2559              %exit %if operands = 0
 2560              %if sym # ',' %then mc error ("Operands?") %else get (sym)
 2561           %repeat
 2562        %finish
 2563        mc error ("Operands?") %if sym # ';'
 2564     %end
 2565  
 2566     %routine  PLANT
 2567        ! Plant in-line code values (from "*=constant")
 2568        %integer  j
 2569        %for j = 1, 1, stp %cycle
 2570           lhs == stacked(j)
 2571           word (lhs_disp)
 2572           drop (lhs)
 2573        %repeat
 2574        stp = 0
 2575     %end
 2576  
 2577     %routine  ASSEMBLE (%integer amode, labs, names)
 2578        !amode : = -1  - recordformat
 2579        !        = -2  - alternate format starting
 2580        !        =  0  - procedure definition
 2581        !        =  1  - procedure spec
 2582        %switch  c (' ' : 127)
 2583        %record(varfm) %name  v
 2584        %record(varfm) %name  gvar == decvar
 2585        %integer %array  string areas (1 : max work)
 2586        %integer  duplic         = 0
 2587        %integer  this area      = 0
 2588        %integer  last area      = 0
 2589        %integer  old mask       = entry mask
 2590        %integer  old ca         = ca
 2591        %integer  old frame      = frame
 2592        %integer  max frame
 2593        %integer  frame base
 2594        %integer  old last local = last local
 2595        %integer  old jump       = uncond jump
 2596        %integer  old ivbit      = ivbit state
 2597        %integer  gstart         = names
 2598        %integer  gfunction      = 0;      !#0 for string/record functions
 2599        %integer  label start    = labs
 2600        %integer  block tag
 2601        %integer  block end tag  = 0
 2602        %integer  local lines    = diag lines;  diag lines = 6
 2603        %integer  local diags    = 0
 2604        %integer  events = 0
 2605        %integer  evlow,  evep
 2606        %integer  proctype, mainprog = 0
 2607  
 2608        %routinespec  DUMP DIAG (%integer flag)
 2609        %routinespec  LOAD (%record(stackfm) %name v, %integer r)
 2610        %routinespec  LRD  (%record(stackfm) %name v, %integer r)
 2611        %routinespec  JUMP TO (%integer label, cond, def)
 2612        %routinespec  TEST ZERO (%record(stack fm) %name d)
 2613        %routinespec  PUSH (%record(stackfm) %name v, %integername n)
 2614  
 2615        !====================== Initialisation =============================
 2616  
 2617        flush code
 2618        uncond jump = -1
 2619        last movc3 = -1
 2620        frame = 0 %if amode # -2
 2621        frame base = frame;   max frame = frame
 2622        ca = 0
 2623        entry mask = 16_3c; entry mask = 0 %if control&1 = 0
 2624        ivbit state = 0
 2625        %if control&ovf check # 0 %start
 2626           entry mask = iovf bit!entry mask
 2627           ivbit state = 1
 2628        %finish
 2629        proctype = potype
 2630        %if amode = 0 %start
 2631           level = level + 1
 2632           error ('!', "nesting too deep") %if level > 6
 2633           local = base reg(level)
 2634           activity(local) = -1
 2635           gfunction = 1 %if gvar_type&(strings!records) # 0 %and
 2636+                            gvar_form = v in r+proc bit
 2637           %if level # 0 %start
 2638              entry mask = entry mask ! regmask(local)
 2639              decvar_disp = newtag %if decvar_disp = 0
 2640              block tag = decvar_disp
 2641              block end tag = new tag
 2642              select output tank (directives);  put (dir header)
 2643              select output tank (object)
 2644              put (obj header)
 2645              put (local-1);  put word (block tag)
 2646              put word (block end tag)
 2647              put word (current line)
 2648              %if proctype # 0 %start;     ! external
 2649                 dump text (externalname)
 2650                 entry mask = entry mask ! 16_800;    ! Save GLA on entry
 2651                 %if command & entrybit # 0 %andc
 2652+                    (entryname = "" %or externalname = entryname) %start
 2653                    mainprog = mainrt;  mainprog = mainfn %if decvar_type # 0
 2654                    define entry (block tag)
 2655                 %finish
 2656              %finish
 2657              define tag (block tag)
 2658              lput (obj pdef, block tag) %if potype # 0
 2659              dump diag (0)
 2660           %finish
 2661        %else %if amode = -1
 2662           gvar_extra = parms
 2663        %finish
 2664  
 2665  
 2666        !===================================================================
 2667  
 2668  
 2669        %routine  SPEC EXTERNAL (%record(varfm) %name v)
 2670           v_base = pc
 2671           select output tank (directives)
 2672           put (dir used);  put word (v_xno)
 2673           select output tank (object)
 2674        %end
 2675  
 2676        %routine  DUMP DIAG (%integer flag)
 2677           %integer type, disp, base, indirect
 2678           %return %if amode # 0 %or command&diag bit = 0
 2679           indirect = 0
 2680           base = decvar_base - 1
 2681           type = decvar_type
 2682           %if flag = 0 %start;       !proc header
 2683              put (obj diag p)
 2684              local diags = local diags+2
 2685           %else %if decvar_form&15 = v in s
 2686              put (obj diag v)
 2687           %else %if decvar_form&15 = a in s
 2688              put (obj diag v)
 2689              indirect = 128
 2690           %else
 2691              %return
 2692           %finish
 2693           local diags = local diags+7+length(var name)
 2694           %if flag = 0 %start
 2695              put word (current line)
 2696           %else
 2697              put (type)
 2698              disp = decvar_disp
 2699              %if base = local-1 %start
 2700                 %if disp >= 0 %start
 2701                    disp = disp+4 %if gfunction # 0
 2702                    disp = disp+4;  base = ap-1
 2703                 %else
 2704                    base = fp-1
 2705                 %finish
 2706              %finish
 2707              put (base!indirect)
 2708              put long (disp)
 2709           %finish
 2710           dump text (var name)
 2711        %end
 2712  
 2713        %routine  SET DOPE VECTOR (%integer %name gdisp)
 2714           gfix (3)
 2715           gdisp = ga
 2716           glongword (1);        !dimension
 2717           glongword (vlb)
 2718           glongword (vub)
 2719           vub = vub-vlb+1
 2720           glongword (data size)
 2721           vlb = vlb*data size
 2722        %end
 2723  
 2724        %routine  DEFINE VAR
 2725           %integer  type, form, tf, s, size
 2726           %integer  new, round, dv
 2727           %own %integer  prim no = 0, xno = 0
 2728  
 2729           new = 0
 2730  
 2731           decl = getword
 2732           %if decl = 0 %start;             !recordformat element
 2733              parms = parms - 1;  decvar == var(parms);  decvar = 0
 2734           %else
 2735              decvar == var(decl)
 2736              %if decl > names %or decvar_xno # 0 %start
 2737                 ! Either a new name or one previously %externally spec'd
 2738                 decvar = 0
 2739                 names = decl %if decl > names
 2740                 new = 1
 2741              %finish
 2742           %finish
 2743           var name = ""
 2744           %cycle
 2745              get (s);  %exit %if s = ','
 2746              var name = var name.tostring(s) %if length(var name) < max ident
 2747           %repeat
 2748           abort (14) %if names >= parms
 2749           get (tf)
 2750           type = tf>>4
 2751           form = fmap(tf&15);           !convert to internal form
 2752           round = 3;  data size = 4;    ! defaults (integer)
 2753           get (discard);  size = getword
 2754           %if type = 1 %start;          ! integer
 2755              type = integers
 2756              %if size = 2 %start
 2757                 type = byte+integers;  round = 0;  size = 1
 2758              %else %if size = 3
 2759                 type = short+integers; round = 1;  size = 2
 2760              %else %if size = 4
 2761                 type = long+integers;  round = 7;  size = 8
 2762              %else
 2763                 size = 4
 2764              %finish
 2765              type = integers %if form = procbit+v in r;  !integer functions
 2766           %else %if type = 2;           ! %real, %longreal
 2767              %if size = 4 %start;       !longreal
 2768                 size = 8;  type = reall;  round = 7
 2769              %else
 2770                 size = 4;  type = reals
 2771              %finish
 2772           %else %if type = 3;           ! %string
 2773              type = strings
 2774              round = 0
 2775              size = size + 1 %if size # 0; !infiltrate length cell, unless (*)
 2776           %else %if type = 4;           ! %record
 2777              type = records
 2778              decvar_format = size
 2779              size = var(size)_length
 2780           %finish
 2781           data size = size;             !actual size
 2782           decvar_length = data size
 2783  
 2784           get (discard);   otype = getlong
 2785           duplic = otype&256
 2786           spec = otype&8;  otype = otype&7;  !ignore prot for now
 2787           %if alias # "" %start
 2788              external name = alias;  alias = ""
 2789           %else
 2790              %if otype = 4 %start;        !system
 2791                 %if length(var name) > max ident-4 %start
 2792                    length(var name) = max ident-4
 2793                 %finish
 2794                 external name = "SYS$".var name
 2795              %else
 2796                 external name = var name
 2797              %finish
 2798           %finish
 2799  
 2800           size = 4 %if gmode # 0 %and amode >= 0 %and type # reall
 2801           !parameters are longwords
 2802           %if form&proc bit # 0 %start;                !procedure
 2803              decvar_type = type;  decvar_form = form
 2804              decvar_header = -1
 2805              gtype = 0
 2806              gtype = 1 %if spec # 0
 2807              %if otype # 0 %and spec # 0 %start;       !external spec
 2808                 %if otype >= 6 %start;                 !primitive, permanent
 2809                    prim no = prim no+1
 2810                    decvar_flags = prim no
 2811                    %return %if otype = 6;              !primitive
 2812                 %finish
 2813                 xno = xno + 1
 2814                 decvar_base = pending;  decvar_xno = xno
 2815                 put (obj pspec); put word (xno); dump text (externalname)
 2816                 %return
 2817              %finish
 2818              %if gmode = 0 %start;                     !not a parameter
 2819                 potype = otype
 2820                 %if new # 0 %start
 2821                    decvar_base = pc
 2822                    decvar_disp = new tag
 2823                 %finish
 2824                 %return
 2825              %finish
 2826              size = 4
 2827           %else
 2828              %if form&(indirect bit!array bit!arrayname bit) # 0 %start
 2829                 size = 4
 2830                 %if form&arrayname bit # 0 %start
 2831                    size = 8;  datasize = 8
 2832                 %else %if form&indirect bit # 0
 2833                    data size = 4
 2834                 %finish
 2835                 round = 3 %if form&(indirect bit!arrayname bit) # 0
 2836                 %if type = 0 %start;          !general type
 2837                    size = 8
 2838                 %else %if form&arrayname bit # 0
 2839                    decvar_header = -1
 2840                 %finish
 2841              %finish
 2842           %finish
 2843           decvar_type = type;  decvar_form = form
 2844  
 2845           !deal with owns
 2846  
 2847           %if otype # 0 %start;                    !own data
 2848              owntype = type;  ownform = form
 2849              %if otype = 2 %and form&indirect bit # 0 %start
 2850                 otype = 0
 2851              %else
 2852                 %if spec = 0 %start
 2853                    %if form&array bit # 0 %start
 2854                       set dope vector (dv)
 2855                       decvar_base = gla;  decvar_disp = ga
 2856                       glongword (0);  glongword (0)
 2857                       decvar_header = -2;  decvar_zeroad = ga - vlb
 2858                       flush gla
 2859  !                     %if command & picbit # 0 %start
 2860  !                        head_base = gla; head_disp = ga - 8
 2861  !                        dope_disp = dv
 2862  !                        zeroth_base = gla; zeroth_disp = ga - vlb
 2863  !                        plant2 (moval, zeroth, head); head_disp = head_disp + 4
 2864  !                        plant2 (moval, dope, head)
 2865  !                     %else
 2866                          put (obj reloc); put long (ga-8); put long (ga-vlb)
 2867                          put (obj reloc); put long (ga-4); put long (dv)
 2868  !                     %finish
 2869                       lput (obj ddef, ga-8) %if otype > 2
 2870                    %finish
 2871                 %else
 2872                    xno = xno+1; decvar_xno = xno; decvar_base = pc
 2873                    s = objdspec;  s = obj weak %if otype = 5
 2874                    put (s); put word (xno); dump text (externalname)
 2875                    ! Externalarrays actually arraynames....
 2876                    decvar_header = -1 %if decvar_form&arraybit # 0
 2877                 %finish
 2878              %finish
 2879              owntype = integers %if form&indirect bit # 0
 2880              owntype = records %if form&arrayname bit # 0;  !to dump a lot
 2881              %return
 2882           %finish
 2883  
 2884           %if form = 15 %start;          !label
 2885              jump to (-decl, 32, 0)
 2886              %return
 2887           %finish
 2888  
 2889           %if form = switch %start
 2890              data size = 4
 2891              gfix (3);   dv = ga
 2892              glongword (1)
 2893              glongword (vlb); glongword (vub)
 2894              glongword (4);      ! data size
 2895              decvar_type  = integers;  decvar_form = av in s
 2896              decvar_base  = gla;       decvar_disp = dv
 2897              decvar_extra = ga-vlb*4
 2898              glongword (0) %for s = vlb, 1, vub
 2899              %return
 2900           %finish
 2901  
 2902           %if form = recfm %start
 2903              gtype = -1
 2904              %return
 2905           %finish
 2906  
 2907           %return %if form&array bit # 0
 2908           %if gmode = 0 %start;               !reverse definition
 2909              frame = (frame-size)&(\round)
 2910              decvar_disp = frame
 2911              last local = frame
 2912           %else
 2913              round = 3 %if amode >=0
 2914              frame = (frame+round)&(\round) %if control&rec round # 0
 2915              decvar_disp = frame
 2916              frame = frame+size
 2917           %finish
 2918           decvar_base = local
 2919           dump diag (1) %if form&arrayname bit = 0
 2920        %end
 2921  
 2922        %routine  DEFINE PARAMETERS
 2923           %integer  p, disp
 2924           gvar_extra = parms
 2925           disp = 64
 2926           disp = 68 %if gfunction # 0
 2927           %for p = gstart+1, 1, names %cycle
 2928              actual == var(p)
 2929              parms = parms - 1;  formal == var(parms)
 2930              formal = actual
 2931              actual_disp = actual_disp+disp
 2932              %if actual_type&(records!strings) # 0 %start
 2933                 !string and record values passed by name
 2934                 actual_form = a in s %if actual_form = v in s
 2935              %finish
 2936           %repeat
 2937           abort (26) %if parms <= names
 2938        %end
 2939  
 2940        %routine  AMAP (%record(stackfm) %name v)
 2941           !convert 'v' into a descriptor for the address of 'v'
 2942           %integer f
 2943           %const %short %array map(constant:a in rec) =
 2944+               -1,     -1,  avins,  -1,   vins, avinrec,  -1,     vinrec
 2945           ! constant, vinr,  vins, avins, ains,  vinrec, avinrec, ainrec
 2946           monitor (v, "Amap in") %if diag&64 # 0
 2947           f = map(v_form&15)
 2948           abort (15) %if f < 0 %or v_oper # 0
 2949           %if f = av in s  %and v_xno = 0 %start
 2950              %if v_base = 0 %start
 2951                 f = constant
 2952              %else %if v_disp = 0 %and v_flags&indexed = 0
 2953                 f = v in r
 2954              %finish
 2955           %finish
 2956           v_form = f
 2957           %if f = v in s %or f = v in rec %start
 2958              v_length = 4
 2959           %else
 2960              v_length = var(v_format)_length %if v_type = records
 2961              v_length = v_iscale %if v_flags&indexed # 0
 2962           %finish
 2963           v_type = integers
 2964           monitor (v, "Amap out") %if diag&64 # 0
 2965        %end
 2966  
 2967        %routine  VMAP (%record(stackfm) %name v)
 2968           %integer n
 2969           monitor (v, "Vmap in") %if diag&64 # 0
 2970           %if v_oper # 0 %start
 2971              %if (v_oper = add %or v_oper = sub) %and const (v_link) %start
 2972                 n = v_link_disp;   drop (v_link)
 2973                 n = -n %if v_oper = sub
 2974                 v_oper = 0
 2975                 %if v_form = v in r %or v_form = av in s %start
 2976                    v_disp = v_disp + n
 2977                 %else %if v_form = v in s %and v_type = integers %and
 2978+                          v_flags&indexed = 0
 2979                    v_extra = v_disp;  v_disp = n
 2980                    v_form = av in rec
 2981                 %else
 2982                    load (v, any);  v_disp = n
 2983                 %finish
 2984              %else
 2985                 load (v, any)
 2986              %finish
 2987           %finish
 2988  !         load (v, any) %if v_flags&indexed # 0 %and v_form # av in s
 2989           %if v_form = v in s %or v_form = v in rec %start
 2990              v_form = v_form+2
 2991           %else %if v_form = av in s %or v_form = av in rec
 2992              v_form = v_form-1
 2993           %else %if v_form = constant
 2994              v_form = v in s;  v_base = 0
 2995           %else
 2996              load (v, any);  v_form = v in s
 2997           %finish
 2998           monitor (v, "Vmap out") %if diag&64 # 0
 2999        %end
 3000  
 3001        %routine  ADDRESS VAR (%integer mode, %record(stack fm) %name v)
 3002           ! If v is av in rec then change form of descriptor
 3003           ! according to mode -
 3004           !   mode # 0 -> value wanted -> make into v in s + const
 3005           !   mode = 0 -> want address -> load base
 3006           %record(stack fm) %name  c
 3007           %integer  n
 3008           %return %if v_form # av in rec
 3009           n = v_disp
 3010           %if mode # 0 %and v_flags = 0 %start
 3011              v_form = v in s;  v_disp = v_extra;  v_type = integers
 3012              %if n # 0 %start
 3013                 c == literal(n);  stp = stp - 1
 3014                 v_oper = add;   v_link == c
 3015              %finish
 3016           %else
 3017              v_disp = v_extra;  v_extra = 0;   v_type = integers
 3018              load (v, any);   v_disp = n
 3019              v_form = av in s
 3020           %finish
 3021        %end
 3022  
 3023     !string constant processing
 3024  
 3025        %record(stackfm) %map  WORK STRING
 3026           %record(stackfm) %name d
 3027           this area = this area + 1
 3028           %if this area > last area %start
 3029              last area = this area
 3030              abort (29) %if last area > max work
 3031              frame = frame - 256
 3032              string areas(last area) = frame
 3033           %finish
 3034           d == descriptor
 3035           d_type = strings;  d_form = v in s
 3036           d_base = local;    d_disp = string areas(this area)
 3037           %result == d
 3038        %end
 3039  
 3040        %routine  DUMP STRING (%integer max)
 3041           %integer j, l
 3042           l = length(text)
 3043           %if max = 0 %start;                !as much as nesc.
 3044              %return %if l = 0
 3045              max = l
 3046           %else;                             !explicit area
 3047              max = max - 1;                  !ignore length cell
 3048              error ('*', "string constant too big") %if max < l
 3049           %finish
 3050           gbyte (length(text))
 3051           gbyte (charno(text,j)) %for j = 1, 1, max
 3052        %end
 3053  
 3054        %routine  GET STRING (%string(*) %name  text)
 3055           %integer n, s
 3056           get (n)
 3057           length(text) = n
 3058           get block (n, charno(text,1))
 3059           %return %if sym = 'G';          !Alias
 3060           s = look;                       !next control item
 3061           %if n = 0 %start;               !null string
 3062              lstack (null string)
 3063           %else
 3064              lstack (ga)
 3065              dump string (0) %unless s = '$' %or s = 'A';    !own strings
 3066           %finish
 3067           lhs_base = gla
 3068           lhs_type = strings
 3069           lhs_format = n + 1
 3070        %end
 3071  
 3072     !jump processing
 3073  
 3074        %record(labelfm) %map  NEW LABEL
 3075           labs = labs + 1;  abort (16) %if labs > max labels
 3076           %result == labels(labs)
 3077        %end
 3078  
 3079        %record(labelfm) %map  FIND (%integer label)
 3080           %integer lp
 3081           %record(labelfm) %name l
 3082           lp = labs
 3083           %while lp # label start %cycle
 3084              l == labels(lp)
 3085              %result == l %if l_id = label
 3086              lp = lp - 1
 3087           %repeat
 3088           %result == null
 3089        %end
 3090  
 3091        %routine  DEFINE LABEL (%integer label)
 3092           %record(labelfm) %name l
 3093           %return %if label = 0;        !jump round proc
 3094           l == find(label)
 3095           %if l == null %start;         !not found
 3096              l == new label
 3097              l_id = label;  l_tag = new tag
 3098           %else %if l_tag < 0 %and label >= 0
 3099              l_tag = new tag
 3100           %finish
 3101           l_tag = l_tag!16_8000
 3102           define tag (l_tag&16_7fff)
 3103           uncond jump = 0;               !you can get here!
 3104        %end
 3105  
 3106        %routine  JUMP TO (%integer label, cond, def)
 3107           %const %byte %array  inv (0 : 15) =
 3108+             0,  1,  4,  5,  2,  3,  6,  7,
 3109+            0+8,1+8,4+8,5+8,2+8,3+8,6+8,7+8
 3110           %integer  ref
 3111           %record(labelfm) %name  lab
 3112           invert = 0
 3113           %return %if label = 0 {jump round routine} %or uncond jump = ca
 3114           cond = inv(cond&15) %if cond&16 # 0
 3115           lab == find(label)
 3116           %if lab == null %start
 3117              lab == new label
 3118              lab_id = label
 3119              lab_tag = new tag
 3120           %else %if lab_tag < 0 %and def # 0
 3121              lab_tag = new tag
 3122           %finish
 3123           %if cond = 32 %start; !from definevar
 3124              decvar_disp = lab_tag&16_7fff
 3125              %return
 3126           %finish
 3127           %if cond = jump %then ref = dir uref %c
 3128+                          %else ref = dir cref
 3129           flush code
 3130           put (obj jump)
 3131           put (cond);  put word (lab_tag&16_7fff)
 3132           define reference (lab_tag&16_7fff, ref)
 3133           ca = ca+2;                        !assume short
 3134           uncond jump = ca %if cond = jump; !no way past here
 3135        %end
 3136  
 3137        %routine  DEFINE SWITCH LABEL
 3138           %integer  tag, switch zero, index
 3139           switch zero = var(getword)_extra;  tag = new tag
 3140           pop lhs;   index = lhs_disp;  drop (lhs)
 3141           define tag (tag);  uncond jump = 0
 3142           flush gla;   put (obj set)
 3143           put long (tag);  put long (switch zero+index*4)
 3144        %end
 3145  
 3146        %routine  SWITCH JUMP
 3147           vstack (var(getword))
 3148           set both;   stp = stp - 2
 3149           lrd (lhs, r1);                      ! index
 3150           lrd (rhs, r2);                      ! address of dope vector
 3151           prim (swjump)
 3152           uncond jump = ca
 3153        %end
 3154  
 3155     !loading routines
 3156  
 3157        %routine  ADDRESS (%record(stackfm) %name v)
 3158           !convert 'v' to a form in which it is directly addressable
 3159           %own %record(stackfm)  xvar = 0
 3160           %integer  type, form, disp, len
 3161           monitor (v, "Address in") %if diag&32 # 0
 3162           load (v, any) %if v_oper # 0
 3163           %if v_form >= v in rec %start
 3164              %if v_disp = 0 %and
 3165+                 v_form = v in rec %and v_flags = 0 = v_xno %start
 3166                 v_form = a in s;  v_disp = v_extra
 3167              %else
 3168                 type = v_type;  form = v_form-3
 3169                 disp = v_disp;  len = v_length
 3170                 v_type = integers;  v_form = v in s;  v_disp = v_extra
 3171                 load (v, any)
 3172                 v_type = type;  v_form = form
 3173                 v_disp = disp;  v_length = len
 3174              %finish
 3175           %finish
 3176           %if v_form = a in s %and (v_xno # 0 %or v_base = 0 %or
 3177+                                    v_flags&indexed # 0) %start
 3178              len = v_length;  type = v_type
 3179              v_form = v in s;  v_length = 4; v_type = integers
 3180              load (v, any)
 3181              v_form = v in s
 3182              v_length = len;  v_type = type
 3183           %finish
 3184           load (v, any) %if v_form = av in s
 3185           %if (v_xno # 0 %or v_base = 0) %and v_flags&xdefer # 0 %start
 3186              xvar_type = integers;  xvar_form = v in s
 3187              xvar_xno = v_xno;  xvar_base = pc;   xvar_disp = v_disp
 3188              load (xvar, any)
 3189              v_base = xvar_base;  v_xno = 0;  v_disp = 0;
 3190              v_flags = v_flags&(\xdefer)
 3191           %finish
 3192           %if v_flags&indexed # 0 %start
 3193              %if v_form = v in s %start
 3194                 %if v_iscale # v_length %start
 3195                    len = v_length;  v_length = v_iscale
 3196                    type = v_type;   v_type = integers
 3197                    v_form = av in s;  load (v, any)
 3198                    v_length = len;  v_type = type
 3199                    v_form = v in s
 3200                 %finish
 3201              %else
 3202                 abort (46)
 3203              %finish
 3204           %finish
 3205           monitor (v, "Address out") %if diag&32 # 0
 3206        %end
 3207  
 3208        %routine  MOVE ARRAYNAME (%record(stackfm) %name v, to)
 3209           %record(stackfm)   w = 0
 3210           %if v_header < 0 %start;        !header complete
 3211              w_base = v_base;   w_disp = v_disp
 3212              w_extra = v_extra; w_type = v_type
 3213              w_xno = v_xno;     w_form = v in s
 3214              %if v_form&15 >= v in rec %start
 3215                 w_form = a in s
 3216                 w_disp = v_extra
 3217              %finish
 3218              plant2 (movq, w, to)
 3219              drop (v)
 3220              %return
 3221           %finish
 3222           w_base = gla
 3223           w_disp = v_header
 3224           w_type = integers
 3225           w_form = v in s
 3226           w_oper = 0
 3227  !?PSR?!        v_form = v in s;    !**************
 3228           %if to ## spv %start
 3229  !?PSR?!            load (v,r3) %if v_base=r0 %or v_base=r1; !*************
 3230              hazard (r0);  hazard (r1)
 3231              claim (r0);  claim (r1)
 3232              plant2 (movq, w, regv(r0))
 3233           %else
 3234              plant2 (movq, w, to)
 3235           %finish
 3236           amap (v);            !*****************
 3237           address (v);      !****************
 3238           %if to ## spv %start
 3239              plant2 (addl, v, regv(r0))
 3240              %if to ## regv(r0) %start
 3241                 plant2 (movq, regv(r0), to)
 3242                 release (r0);  release (r1)
 3243              %finish
 3244           %else
 3245              w_base = sp;  w_disp = 0
 3246              plant2 (addl, v, w)
 3247           %finish
 3248           release (v_base) %if v_form = v in r;!********************
 3249           drop (v)
 3250        %end
 3251  
 3252        %routine  STRING OP (%integer op, %record(stackfm) %name from, to)
 3253           %integer  old control = control, tl = to_length
 3254           %record(stackfm) %name reg, len
 3255           %if from_flags&indexed # 0 %start
 3256              amap (from);  load (from, any)
 3257              from_form = v in s;  from_type = strings
 3258           %finish
 3259           to_length = 1;                         ! byte context for MOVC3
 3260           address (from);  address (to)
 3261           reg == regv(register(0))
 3262           plant2 (movzbl, from, reg)
 3263           claim (from_base)
 3264           claim (reg_base)
 3265           %if op&len check # 0 %start
 3266              test assigned (from)
 3267              control = control&(\ass check);     ! So won't be done twice
 3268              op = op - len check
 3269              len == literal(tl-1)
 3270              len_type = byte+integers
 3271              plant2 (cmpl+byte, len, reg)
 3272              pop drop
 3273              prim (test string ovf)
 3274           %finish
 3275           plant1 (incl, reg)
 3276           string3 (op, reg, from, to)
 3277           release (reg_base)
 3278           control = old control
 3279        %end
 3280  
 3281        %routine  ASSIGN STRING (%record(stackfm) %name from, to)
 3282           %record(stackfm) %name len
 3283           %integer  op
 3284           %if from_format # 0 %start;          !string constant
 3285              address (to)
 3286              %if from_format = 0+1 %start;     !null string
 3287                 plant1 (clrl+byte, to);        !*clrb_to
 3288                 %return
 3289              %finish
 3290              len == literal(from_format);  stp = stp-1;  drop (len)
 3291              %if 0 # to_length < len_disp %start
 3292                 error ('*', "string constant will overflow destination")
 3293              %finish
 3294              string3 (movc3, len ,from, to)
 3295           %else
 3296              op = movc3
 3297              %if control&str check # 0 %start
 3298                 %if to_type&4 = 0  {dest not work string} %and
 3299+                    0 < to_length < 256 {ovf possible} %start
 3300                    op = op ! len check
 3301                 %finish
 3302              %finish
 3303              string op (op, from, to)
 3304           %finish
 3305        %end
 3306  
 3307        %routine  CONC (%record(stackfm) %name to, with)
 3308           %record(stackfm) %name t
 3309           %record(stackfm) temp, rest, len
 3310           %integer  to len, wlen, total = 0, op
 3311           to len = to_format-1;  wlen  = with_format-1
 3312           %if wlen > 0 %and to len > 0 %start
 3313              ! Initial concat of const/literal strings
 3314              total = wlen + tolen
 3315           %finish
 3316           %if to_type&4 = 0 %start;           ! first one
 3317              t == work string;  stp = stp - 1
 3318              temp = t
 3319              t_type = strings!4;              ! mark as w/string to skip
 3320              assign string (to, t);           ! length check
 3321              drop (t)
 3322           %else
 3323              temp = to
 3324           %finish
 3325           %if wlen = 0 %start;                ! x."" ???
 3326              drop (with)
 3327              %return
 3328           %finish
 3329           op = 0;                             ! 'concat' in STRING OP
 3330           rest = 0
 3331           rest_base = r3
 3332           rest_form = v in s;                 ! r3 points to free byte in temp
 3333           claim (r3)
 3334           %if last movc3 # ca %start;         ! r3 undefined
 3335              %if temp_type&4 = 0 %and to len >= 0 %start
 3336                 ! Can work out start of area for new string
 3337                 rest = temp
 3338                 rest_disp = rest_disp + (to len + 1)
 3339                 release (r3);                  ! unused..
 3340              %else
 3341                 plant2 (movzbl, temp, regv(r3))
 3342                 temp_index = r3;  claim (r3!128)
 3343                 temp_flags = indexed
 3344                 temp_disp = temp_disp+1
 3345                 plant2 (movab, temp, regv(r3))
 3346                 temp_disp = temp_disp-1
 3347                 temp_flags = 0
 3348              %finish
 3349           %finish
 3350           len = 0
 3351           len_type = integers;  len_length = 4
 3352           %if wlen > 0 %start;         ! constant
 3353              len_form = constant
 3354              len_disp = wlen
 3355           %else
 3356              %if with_flags&indexed # 0 %start
 3357                 amap (with);  load (with, any)
 3358                 with_form = v in s
 3359              %finish
 3360              %if with_form # v in s %start
 3361                 load (with, any)
 3362                 with_form = v in s
 3363                 with_type = strings
 3364              %finish
 3365              %if activity(with_base) = 1 %start
 3366                 ! use auto inc to skip length byte
 3367                 with_flags = auto i
 3368                 op = movc3
 3369              %finish
 3370              claim (with_base)
 3371              len_form = v in r
 3372              len_base = register (0)
 3373              plant2 (movzbl, with, len)
 3374              with_flags = 0
 3375              claim (len_base)
 3376           %finish
 3377           %if total > 0 %start;        ! Const total length
 3378              %if total > 255 %start
 3379                 error ('*', "string concatenation results in overflow")
 3380                 total = 255
 3381              %finish
 3382              plant2 (movb, literal(total), temp)
 3383              pop drop
 3384           %else
 3385              iovf off
 3386              len_type = byte+integers
 3387              plant2 (addb2, len, temp)
 3388              prim (test string ovf) %if control&str check # 0
 3389              iovf on
 3390           %finish
 3391           string3 (op!no ass chk, len, with, rest)
 3392           release (len_base)
 3393           drop (with)
 3394           to = temp
 3395           to_type = strings!in work
 3396        %end
 3397  
 3398        %routine  FLOAT (%record(stackfm) %name  v)
 3399           %integer  r
 3400           monitor (v, "Float in") %if diag&2 # 0
 3401           address (v)
 3402           %if v_form = constant %and v_oper = 0 %start
 3403              v_type = reall
 3404              v_lrval = v_disp;      !float it here
 3405              %return
 3406           %finish
 3407           load (v, any) %if v_type = byte+integers %or v_oper # 0
 3408           r = fpr
 3409           plant2 (cvtld+(v_type&7)*8, v, regv(r))
 3410           claim (r);  clear (v)
 3411           v_base = r;  v_disp = 0; v_xno = 0
 3412           v_type = reall;  v_form = v in r
 3413           monitor (v, "Float out") %if diag&2 # 0
 3414        %end
 3415  
 3416        %routine  EQUATE (%record(stackfm) %name a, b, %integer either)
 3417           %record(stackfm) %name x, y
 3418           %integer  key
 3419           %switch  op (0 : 4)
 3420           %const %byte %array  map (0 : 24) =
 3421+             0,2,2,3,3, 1,0,2,3,3, 1,1,0,3,3, 4,4,4,0,1, 4,4,4,2,0
 3422           %return %if a_type = b_type
 3423           x == b;  y == a
 3424           key = (a_type&15)*5+b_type&15
 3425           -> op(map(key))
 3426        op(1):
 3427           %return %if either = 0
 3428           x == a;  y == b
 3429        op(2):
 3430           load (x, any) %if x_form # constant
 3431           x_type = y_type
 3432           %return
 3433        op(3):
 3434           %return %if either = 0
 3435           x == a;  y == b
 3436        op(4):
 3437           float (x)
 3438           x_type = y_type %if x_form = constant
 3439        op(0):
 3440        %end
 3441  
 3442        %predicate  SIMPLE SHIFT (%record(stackfm) %name from, to)
 3443           %record(stackfm) %name  with, lit1, lit2
 3444           %integer pos, size
 3445           %false %unless (from_oper = lsh %or from_oper = rsh) %and
 3446+                         to_type = integers
 3447           with == from_link
 3448           pos = -with_disp
 3449           %false %unless pos >= 0 %and with_form = constant
 3450           from_oper = 0;  drop (with)
 3451           size = 32
 3452           size = 16 %if from_type = short+integers
 3453           size = 8  %if from_type = byte+integers
 3454           pos = size %if pos > size
 3455           size = size - pos;              !size of result
 3456           address (from);  address (to)
 3457           lit1 == literal(pos)
 3458           lit2 == literal(size);  lit2_type = byte+integers
 3459           plant4 (extzv, lit1, lit2, from, to)
 3460           pop drop;   pop drop
 3461           clear (from);  drop (from)
 3462           %true
 3463        %end
 3464  
 3465        %routine  LOAD (%record(stackfm) %name  v, %integer  reg)
 3466           !load the entity described by 'v' into reg
 3467           %integer  oper, op, other, type, vtype, two op = 0
 3468           %record(stackfm) %name  w, rv, x
 3469           %switch  iop (not : brem), rop (not : brem)
 3470  
 3471           abort (37) %unless r0 <= reg <= fpr4; !load what???
 3472           used(reg) = ca %if reg < any;         !prevent intermediate use
 3473           %if v_oper = 0 %and v_form = av in rec %start
 3474              address var (1, v)
 3475           %finish
 3476           type = v_type;  vtype = integers;     !default
 3477           oper = v_oper
 3478           monitor (v, "Load ".reg name(reg)) %if diag&2 # 0
 3479           %unless fpr0 <= reg <= fpr4 %or floating (v) %start
 3480              ! Load integer
 3481              %if oper # 0 %start;               !complex descriptor
 3482                 v_oper = 0
 3483                 w == v_link
 3484                 %if oper = exp %start
 3485                    load (v, r1);  load (w, r2)
 3486                    drop (w)
 3487                    release (r1);  release (r2)
 3488                    prim (exp int)
 3489                    v_base = r0;  claim (r0)
 3490                    load (v, reg) %unless reg = any
 3491                    %return
 3492                 %finish
 3493                 %if oper = rsh %or oper = lsh %start
 3494                    ! These take BYTE shift counts
 3495                    load (w, any) %if w_flags&indexed # 0 %and
 3496+                                     w_type # byte+integers
 3497                 %finish
 3498                 %if oper = rsh %or oper = remy %start
 3499                    ! fiddly - need reg pair...
 3500                    load (v, register(1)) %unless in free reg (v) %and
 3501+                                                 activity(v_base+1) = 0
 3502                    other = v_base+1
 3503                    abort (30) %if activity(other) < 0
 3504                    hazard (other);           !reg is never r10
 3505                    %if oper = rsh %start
 3506                       plant1 (clrl, regv(other))
 3507                    %else
 3508                       !rem - sign extend to 2nd register
 3509                       %if const (v) %start
 3510                          plant2 (movl, literal(-(v_disp>>31)), regv(other))
 3511                          pop drop
 3512                       %else
 3513                          plant4 (extv, literal(31), literal(1),
 3514+                                 regv(v_base), regv(other))
 3515                          pop drop;  pop drop
 3516                       %finish
 3517                    %finish
 3518                    claim (other)
 3519                    address (w)
 3520                    w_type = integers %if oper = rsh;    ! to prevent loading
 3521                 %else
 3522                    %if v_type = integers %start
 3523                       address (v)
 3524                    %else
 3525                       load (v, reg);  reg = v_base
 3526                    %finish
 3527                 %finish
 3528                 %if oper >= add %start
 3529                    address (w)
 3530                    load (w, any) %if w_type # integers
 3531                    op = op map(oper)
 3532                 %finish
 3533                 %if oper # rsh %start
 3534                    %if reg = any %start
 3535                       %if oper >= add %and op # 0 %start;! two op possible?
 3536                          %if op&commute # 0 %and in free reg (w) %start
 3537                             reg = w_base; x == v; two op = 1
 3538                          %else %if in free reg (v)
 3539                             reg = v_base; x == w; two op = 1
 3540                          %finish
 3541                       %finish
 3542                       reg = register (0) %if reg = any;  ! Not yet got one?
 3543                    %else
 3544                       hazard (reg) %unless v_base = reg %or
 3545+                                           (oper >= add %and w_base = reg)
 3546                    %finish
 3547                    rv == regv(reg)
 3548                 %finish
 3549  
 3550                 -> iop(oper)
 3551  
 3552        iop(neg):plant2 (mnegl, v, rv);  -> set
 3553        iop(not):plant2 (mcoml, v, rv);  -> set
 3554  
 3555        iop(mul):
 3556                 %if w_form = constant %and (w_disp = 2 %or w_disp = 4) %start
 3557                    plant2 (movl, v, rv) %if two op = 0
 3558                    plant2 (addl, rv, rv)
 3559                    plant2 (addl, rv, rv) %if w_disp = 4
 3560                    -> wset
 3561                 %finish
 3562        iop(add):
 3563        iop(or ):
 3564        iop(xor):
 3565        iop(sub):
 3566        iop(div):
 3567        iop(bic):
 3568                 %if two op # 0 %start
 3569                    plant2 (op - three op, x, rv)
 3570                 %else
 3571                    plant3 (op, w, v, rv)
 3572                 %finish
 3573                 -> wset
 3574        iop(remy):
 3575                 plant4 (ediv, w, v, rv, rv)
 3576                 release (other)
 3577                 -> wset
 3578        iop(lsh):
 3579        iop(rsh):  ! rsh converted
 3580                 w_type = byte+integers
 3581                 w_disp = w_disp&255 %if const (w)
 3582                 iovf off
 3583                 %if oper = lsh %start
 3584                    plant3 (ashl, w, v, rv)
 3585                    iovf on
 3586                 %else
 3587                    plant3 (ashq, w, v, v)
 3588                    iovf on
 3589                    release (other)
 3590                    load (v, reg)
 3591                    clear (w);  drop (w)
 3592                    %return
 3593                 %finish
 3594  
 3595        wset:    clear (w);  drop (w)
 3596                 -> set
 3597  
 3598        iop(*):  abort (33)
 3599  
 3600              %else
 3601                 ! just a simple descriptor
 3602                 amap (v) %if type&strings # 0;   !only need address of string
 3603                 %if reg = any %start;            !none in particular
 3604                    ! select an appropriate register
 3605                    %if activity (v_base) = 1 %start
 3606                       ! Use own base
 3607                       %return %if v_form = v in r; !ok where it is
 3608                       reg = v_base
 3609                    %else;                        !any other will do
 3610                       reg = register(0)
 3611                    %finish
 3612                 %else;                           !specific register required
 3613                    %if reg = v_base %start
 3614                       %return %if v_form = v in r
 3615                    %else
 3616                       hazard (reg)
 3617                    %finish
 3618                 %finish
 3619              %finish
 3620           %else
 3621              ! Load real
 3622              vtype = reall
 3623              %if oper # 0 %and %not floating(v) %start
 3624                 ! integer operation pending
 3625                 load (v, any);  oper = 0
 3626              %finish
 3627              %if oper # 0 %start
 3628                 v_oper = 0;  w == v_link
 3629                 %if oper = rexp %start
 3630                    load (v, fpr2)
 3631                    load (w, r4)
 3632                    drop (w)
 3633                    release (fpr2); release (r4)
 3634                    prim (exp real)
 3635                    v_base = fpr0;  claim (fpr0)
 3636                    load (v, reg) %unless reg = any
 3637                    %return
 3638                 %finish
 3639                 %if v_type # reall %start
 3640                    float (v) %unless v_type = reals;!??something fishy here??
 3641                    load (v, reg);  reg = v_base
 3642                 %else
 3643                    address (v)
 3644                 %finish
 3645                 %if oper >= add %start
 3646                    address (w)
 3647                    float (w) %unless floating (w)
 3648                    load (w, any) %unless w_type = reall
 3649                    clear (w);  drop (w)
 3650                 %finish
 3651                 %if reg = any %start
 3652                    %if v_form = v in r %then reg = v_base %else reg = fpr
 3653                 %else
 3654                    hazard (reg) %unless reg = v_base
 3655                 %finish
 3656                 rv == regv(reg)
 3657                 -> rop(oper)
 3658  
 3659        rop(neg):plant2 (mnegd, v, rv);              -> set
 3660  
 3661        rop(add):plant3 (addd+three op, v, w, rv);   -> set
 3662        rop(sub):plant3 (subd+three op, w, v, rv);   -> set
 3663        rop(mul):plant3 (muld+three op, v, w, rv);   -> set
 3664        rop(rdiv):plant3 (divd+three op, w, v, rv);  -> set
 3665  
 3666        rop(*):  abort (32)
 3667  
 3668              %else
 3669                 ! Simple real object
 3670                 float (v) %and type = reall %if type&real bit = 0
 3671                 %if reg = any %start
 3672                    %return %if v_form = v in r %and v_type = reall
 3673                    reg = fpr
 3674                 %else
 3675                    %return %if reg = v_base
 3676                    hazard (reg)
 3677                 %finish
 3678              %finish
 3679           %finish
 3680           op = (7+type&7)*8 + vtype&7
 3681           op = movl %if type = integers %or zero (v)
 3682           %if v_form = av in s %or v_form = av in rec %start
 3683              op = moval + type&7
 3684              v_form = v_form - 1
 3685           %finish
 3686           address (v)
 3687           scale index (op, v)
 3688           plant2 (op, v, regv(reg))
 3689        set:
 3690           clear (v)
 3691           claim (reg)
 3692           v_type = vtype
 3693           v_form = v in r
 3694           v_base = reg
 3695           v_disp = 0;  v_extra = 0
 3696           v_xno  = 0;  v_flags = 0
 3697        %end
 3698  
 3699        %routine  COP (%integer op, %integername l, %integer r)
 3700           !perform a compile-time operation
 3701           %switch  c (not : brem)
 3702           -> c (op)
 3703        c(add):   l = l+r;        %return
 3704        c(sub):   l = l-r;        %return
 3705        c(bsub):  l = r-l;        %return
 3706        c(mul):   l = l*r;        %return
 3707        c(div):   error ('*', "cannot divide by 0") %and r = 1 %if r = 0
 3708                  l = l//r;       %return
 3709        c(remy):  error ('*', "cannot take REM (c, 0)") %and r = 1 %if r = 0
 3710                  l = l-l//r*r;  %return
 3711        c(bic):   l = l&(\r);     %return
 3712        c(or ):   l = l!r;        %return
 3713        c(xor):   l = l!!r;       %return
 3714        c(rsh):!!!!!! rsh is same as lsh with shift negated, so << NOT >>
 3715        c(lsh):   l = l>>(-r);       %return
 3716        c(exp):   l = l\\r;       %return
 3717        c(neg):
 3718        c(not):
 3719        c(rdiv):
 3720        c(rexp):
 3721        c(*):
 3722           abort (19)
 3723        %end
 3724  
 3725        %routine  OPERATE (%integer oper)
 3726           %integer  key, lcon, rcon, wcon, lop, rop, scale, j
 3727           %record(stackfm) %name  with, lh, rh
 3728  
 3729           %routine  LOSE (%record(stackfm) %name  v)
 3730              %if v_oper > neg %start
 3731                 clear (v_link);  drop (v_link)
 3732              %finish
 3733              clear (v);  drop (v)
 3734           %end
 3735  
 3736           %routine  SWAP
 3737              %record(stackfm)  temp
 3738              %integer  t
 3739              temp = lh;    lh   = rh;    rh   = temp
 3740              t    = lcon;  lcon = rcon;  rcon = t
 3741              lop = lh_oper;  rop = rh_oper
 3742           %end
 3743  
 3744           %predicate  GOOD BASE (%record(stack fm) %name  v, %integer mult)
 3745              ! Is v a suitable candidate for doing addition
 3746              ! by address op fiddling?
 3747              %integer f, t, d
 3748              ! directly usable?
 3749              %false %if v_flags&indexed # 0;        ! already indexed
 3750              %false %if v_oper # 0
 3751              %if v_form = constant %and v_type = integers %and
 3752+                 %not 0 <= v_disp <= 63 %and mult # 1 %start
 3753                 v_form = av in s;   v_base = 0
 3754              %finish
 3755              f = v_form;  t = v_type
 3756              %true %if f = av in s %or
 3757+                       (mult # 1 %and t = integers %and
 3758+                        f = v in s);                ! useable directly
 3759              %false %unless f = av in rec %or
 3760+                           (mult # 1 %and t = integers %and f = v in rec)
 3761              v_form = v in s;  d = v_disp;  v_disp = v_extra
 3762              %if d = 0 %and f = v in rec %start
 3763                 v_form = a in s
 3764                 f = av in rec;    ! => av in s
 3765              %finish
 3766              load (v, any)
 3767              v_disp = d;  v_form = f - rec mod
 3768              %true
 3769           %end
 3770  
 3771           %if diag&256 # 0 %start
 3772              print string ("Operate: ")
 3773              print string (op name(oper))
 3774              newline
 3775           %finish
 3776  
 3777           %if oper <= neg %start;    !unary
 3778              abort (17) %if stp <= 0
 3779              lh == stacked(stp);  lop = lh_oper
 3780              monitor (lh, "Oper in TOS") %if diag&256 # 0
 3781              %if const (lh) %start
 3782                 lh_disp = \lh_disp+oper-not;  ! generates - or \ as req.
 3783              %else %if lh_form = constant %and lop = 0;  ! real constant
 3784                 lh_lrval = -lh_lrval
 3785              %else %if 0 # lop <= neg;        ! unary pending
 3786                 %if oper = lop %start;        ! -(-A) => A
 3787                    lh_oper = 0
 3788                 %else
 3789                    cstack (2*(oper-not)-1);   ! neg=8,not=7
 3790                    operate (add)
 3791                 %finish
 3792              %else
 3793                 %if lop # 0 %start
 3794                    %if oper = neg %and lop = sub %start
 3795                       ! -(A-B) => B-A
 3796                       with == lh_link;  lh_link == null; oper = 0
 3797                       with_link == lh;  with_oper = sub
 3798                       stacked(stp) == with
 3799                    %else
 3800                       load (lh, any)
 3801                    %finish
 3802                 %finish
 3803                 lh_oper = oper;  lh_link == null
 3804              %finish
 3805              -> out
 3806           %finish
 3807  
 3808           abort (18) %if stp <= 1
 3809           stp = stp - 1;                     ! pop one
 3810           lcon = 0;  rcon = 0;  wcon = 0
 3811           lh == stacked(stp)
 3812           rh == stacked(stp+1)
 3813  
 3814           %if diag&256 # 0 %start
 3815              monitor (lh, "Oper in LHS")
 3816              monitor (rh, "Oper in RHS")
 3817           %finish
 3818  
 3819           ! LH oper RH
 3820  
 3821           %if const (lh) %start
 3822              %if lh_disp = lnull op(oper) # no null %start
 3823                 ! eg 0 + RH
 3824                 stacked(stp) == rh
 3825                 drop (lh)
 3826                 -> out
 3827              %finish
 3828              %if lh_disp = 0 %and
 3829+                 (oper = rsh %or oper = lsh %or oper = remy) %start
 3830                 ! 0>>anything = 0
 3831                 ! 0<<anything = 0
 3832                 ! rem (0, anything) = 0
 3833                 lose (rh)
 3834                 lh_disp = 0
 3835                 -> out
 3836              %finish
 3837              lcon = 1
 3838           %finish
 3839           %if const (rh) %start
 3840              %if rh_disp = rnull op(oper) # no null %start
 3841                 ! eg LH // 1
 3842                 drop (rh)
 3843                 -> out
 3844              %else %if (oper = rsh %and rh_disp > 31) %or
 3845+                       (oper = lsh %and rh_disp < -31)
 3846                 ! eg J << 45 = 0
 3847                 lose (lh)
 3848                 stacked(stp) == rh;  rh_disp = 0
 3849                 -> out
 3850              %else %if oper = remy %and |rh_disp| = 1
 3851                 ! rem(x,1) = rem(x,-1) = 0
 3852                 lose (lh)
 3853                 stacked(stp) == rh;  rh_disp = 0
 3854                 -> out
 3855              %finish
 3856              rcon = 1
 3857              %if oper = sub %start
 3858                 rh_disp = -rh_disp
 3859                 oper = add
 3860              %finish
 3861           %finish
 3862           %if lcon&rcon # 0 %and oper # rdiv %and oper # rexp %start
 3863              cop (oper, lh_disp, rh_disp);  drop (rh)
 3864              -> out
 3865           %finish
 3866           swap %if lcon # 0 %and comm(oper) # 0;  ! get var oper const
 3867           lop = lh_oper;   rop = rh_oper
 3868           %if lop # 0 %start
 3869              ! (LH lop WITH) oper RH
 3870              with == lh_link
 3871              wcon = 1 %if lop > neg %and const (with)
 3872              %if wcon&rcon # 0 %start
 3873                 key = trans(oper)!trans(lop)
 3874                 %if key = 0 %or (key = 1 %and oper = lop) %start
 3875                    cop (oper, with_disp, rh_disp)
 3876                    drop (rh)
 3877                    %if with_disp = rnull op(lop) # no null %start
 3878                       ! Can now remove WITH
 3879                       lh_oper = 0;  drop (with)
 3880                    %finish
 3881                    -> out
 3882                 %finish
 3883              %finish
 3884              swap %if oper = add %and rop = 0
 3885           %finish
 3886           load (lh, any) %if lh_oper # 0
 3887           %if rcon # 0 %start
 3888              %if rh_disp = -1 %and (oper = mul %or oper = xor) %start
 3889                 %if oper = mul %start
 3890                    lh_oper = neg;        ! A*(-1) -> -A
 3891                 %else
 3892                    lh_oper = not;        ! A!!(-1) -> \A
 3893                 %finish
 3894                 drop (rh);   -> out
 3895              %else %if oper = add %and lh_type = integers
 3896                 ! a+const (not short lit)
 3897                 %if lh_form = v in r %and %not -63 <= rh_disp <= 63 %start
 3898                    lh_form = av in s;  lh_disp = 0
 3899                 %finish
 3900                 %if (lh_form = av in s %or lh_form = av in rec) %and
 3901+                     lh_flags&xdefer = 0 %start
 3902                    lh_disp = lh_disp+rh_disp
 3903                    drop (rh);   -> out
 3904                 %finish
 3905              %else %if oper = bic %and rh_disp = \255 %and
 3906+                       lh_flags&indexed = 0 %and lh_form # v in r
 3907                 !int&255 -> byte
 3908                 address (lh) %and test assigned (lh) %if lh_type = integers
 3909                 lh_type = byte+integers
 3910                 drop (rh);   -> out
 3911              %finish
 3912           %finish
 3913           %if oper = add %start
 3914              ! Here LH + (RH {rop X}?)
 3915              ! Look for various fiddles involving address ops
 3916              ! and indexing
 3917              scale = 1
 3918              %if rop > neg %start
 3919                 with == rh_link
 3920                 %if const (with) %and (rop = mul %or rop = lsh) %start
 3921                    j = with_disp
 3922                    j = 1<<j %if rop = lsh
 3923                    %if j = 2 %or j = 4 %or j = 8 %start
 3924                       scale = j
 3925                    %finish
 3926                 %finish
 3927              %finish
 3928              %if good base (lh, scale) %start
 3929                 ! OK
 3930              %else %if good base (rh, 1)
 3931                 swap
 3932              %else
 3933                 -> no joy
 3934              %finish
 3935              %if scale # 1 %start
 3936                 rh_oper = 0;  rop = 0
 3937                 drop (with)
 3938              %finish
 3939              -> no joy %if scale = 1 %and lh_form = v in s
 3940              load (rh, any)
 3941              lh_index = rh_base;  release (rh_base);  drop (rh)
 3942              lh_flags = indexed;  claim (lh_index!128)
 3943              lh_flags = lh_flags!xdefer %if lh_form = v in s
 3944              lh_iscale = scale;  lh_length = scale
 3945              lh_form = av in s
 3946              -> out
 3947  no joy:
 3948           %finish
 3949           %if rop # 0 %start
 3950              ! LH oper (RH rop WITH)
 3951              with == rh_link
 3952              %if rop = neg %and (oper = add %or oper = sub) %start
 3953                 !   A+(-B) -> A-B
 3954                 oper = add+sub-oper
 3955                 rh_oper = 0
 3956              %else
 3957                 load (rh, any)
 3958              %finish
 3959           %finish
 3960           lh_oper = oper;  lh_link == rh
 3961  out:     monitor (lh, "Oper out") %if diag&256 # 0
 3962        %end
 3963  
 3964  ! Following should really be operations..
 3965  
 3966        %routine  ADDRESS OP (%integer code)
 3967           ! Evaluate  LHS ++ RHS
 3968           %integer  type, len
 3969           set both
 3970           type = lhs_type;  len = lhs_length
 3971           error ('*', "object length unspecified for ++ or --") %if len = 0
 3972           amap (lhs)
 3973           cstack (len);  operate (mul)
 3974           %if code = 117 %then operate (add) %else operate (sub)
 3975           vmap (lhs)
 3976           lhs_type = type;   lhs_length = len
 3977        %end
 3978  
 3979        %routine  CONCATENATE
 3980           ! Evaluate LHS . RHS
 3981           set both
 3982           conc (lhs, rhs)
 3983           stp = stp - 1
 3984        %end
 3985  
 3986        %routine  SET MODULUS
 3987           ! Evaluate  |LHS|
 3988           !
 3989           ! Generates the sequence
 3990           !    Load    LHS,Rn
 3991           !    TSTL    Rn
 3992           !    BGEQ    Pos
 3993           !    MNEGx   Rn, Rn
 3994           ! Pos:
 3995           !
 3996           ! leaving |LHS| in a register
 3997           %integer  op
 3998           set lhs
 3999           %if lhs_form = constant %and lhs_oper = 0 %start
 4000              ! Do it in line...
 4001              %if lhs_type&integers # 0 %start
 4002                 lhs_disp = |lhs_disp|
 4003              %else %if lhs_type = reall
 4004                 lhs_lrval = -lhs_lrval %if lhs_lrval < 0
 4005              %else
 4006                 abort (48)
 4007              %finish
 4008           %else
 4009              load (lhs, any)
 4010              test zero (lhs);    claim (lhs_base)
 4011              word (bgeq+3<<8)
 4012              op = mnegl
 4013              op = mnegd %if lhs_type&real bit # 0
 4014              plant2 (op, lhs, lhs);                ! 3 bytes..
 4015           %finish
 4016        %end
 4017  
 4018        %routine  ASSIGN (%integer assop)
 4019           !assop = -1 : parameter assignment
 4020           !      =  0 : == assignment
 4021           !      =  1 : = assignment
 4022           !      =  2 : <- assignment
 4023           %integer  op, oper, work, move, slen, dlen, total, loop ca
 4024           %integer  st, dt, wt
 4025           %const %string(2) %array  assym (-1 : 2) =
 4026+             "p=", "==", "= ", "<-"
 4027           %record(varfm) %name  vv
 4028           %record(stackfm) %name  source, dest, len, w, count
 4029  
 4030           %routine  SHAPE UP (%integer type, %record(stackfm) %name cc)
 4031              ! Get cc into a form such that OPERAND won't complain
 4032              ! about size of constants, eg short = 16_FFFF would be wrong
 4033              %if type = byte+integers %start
 4034                 cc_disp = cc_disp & 255
 4035              %else %if type = short+integers
 4036                 cc_disp = cc_disp & 16_FFFF;    ! splat top bits
 4037                 ! Sign extend short, ie bits <31:15> all 0 or all 1)
 4038                 cc_disp = cc_disp!(\16_FFFF) %if cc_disp&16_8000 # 0
 4039              %finish
 4040              cc_type = type
 4041           %end
 4042  
 4043           dest   == stacked(stp-1)
 4044           source == stacked(stp)
 4045  
 4046           %if diag&128 # 0 %start
 4047              monitor (source, "Ass ".assym(assop)." srce")
 4048              monitor (dest,   "       dest")
 4049           %finish
 4050  
 4051           %if assop < 0 %start;                  !parameter assignment
 4052              load (source, any) %if source_oper # 0
 4053              dest_extra = dest_extra-1
 4054              vv == var(dest_extra)
 4055              %if vv_form # v in s %start
 4056                 %if vv_form&arrayname bit # 0 %start
 4057                    source_oper = 1
 4058                 %else %if vv_form &proc bit # 0
 4059                    %unless r6 <= source_base <= r9 %start;!not already a param
 4060                       w == temp(24);  stp = stp - 1
 4061                       w_base = fp;  work = w_disp
 4062                       %if source_xno # 0 %start;        !external
 4063                          source_form = v in s
 4064                          plant2 (moval, source, w)
 4065                       %else;                            !normal routine
 4066                          hazard (r10)
 4067                          put code (opcode(moval&255))
 4068                          flush code
 4069                          define reference (source_disp, dirpref)
 4070                          put (obj call);  put long (source_disp);  ca = ca+2
 4071                          put number byte (16_5a)
 4072                          !moval p,r10
 4073                          entry mask = entry mask ! 16_400;  ! save R10
 4074                          local = local!128; !prevent OPERAND changing it to FP
 4075                          plant2 (movl, regv(r10), w)
 4076                          %if local = r6!128 %then move = movl %c
 4077+                                            %else move = movq
 4078                          w_disp = w_disp+4
 4079                          plant2 (move, regv(r6), w)
 4080                          w_disp = w_disp+8
 4081                          %if local > r7!128 %start
 4082                              %if local = r8!128 %then move = movl %c
 4083+                                                %else move = movq
 4084                             plant2 (move, regv(r8), w)
 4085                          %finish
 4086                          w_disp = w_disp + 8
 4087                          plant2 (movl, regv(gla), w)
 4088                          local = local&127
 4089                       %finish
 4090                       drop (source);  source == w;  source_disp = work
 4091                       w_base = local
 4092                       source_form = av in s
 4093                    %else
 4094                       source_form = v in s
 4095                    %finish
 4096                    source_type = integers
 4097                 %else %if vv_type = 0;          !general type
 4098                    source_oper = 2
 4099                    source_oper = 3 %if source_type = 0;  !also general
 4100                 %else
 4101                    amap (source)
 4102                 %finish
 4103              %else %if vv_type&real bit # 0
 4104                 float (source) %unless floating (source)
 4105                 %if vv_type = reall %and source_type = reals %start
 4106                    load (source, any)
 4107                 %else %if vv_type = reals
 4108                    source_type = reals
 4109                 %finish
 4110              %finish
 4111              %if vv_type = records %and source_format = 0 %start
 4112                 ! Passing rec(*) as value (parameter typed)
 4113                 source_format = vv_format
 4114              %finish
 4115              source_link == dest_link
 4116              dest_link == source
 4117              stp = stp-1
 4118              %return
 4119           %finish
 4120  
 4121           stp = stp-2
 4122           %if dest_form&arrayname bit # 0 %start
 4123              op = dest_form&15
 4124              %if op >= v in rec %then op = v in rec %c
 4125+                                %else op = v in s
 4126              dest_form = op
 4127              address (dest)
 4128              move arrayname (source, dest)
 4129              clear (dest);  drop (dest)
 4130              %return
 4131           %finish
 4132  
 4133           %if assop = 0 %start;               !==
 4134              amap (source);  amap (dest)
 4135           %finish
 4136  
 4137           %if same (source, dest) %start;     ! ????
 4138              clear (source);  drop (source)
 4139              clear (dest);    drop (dest)
 4140              %return
 4141           %finish
 4142  
 4143           %if source_oper = 0 %and source_form = av in rec %start
 4144              address var (1, source)
 4145           %finish
 4146           %if dest_type&strings # 0 %start
 4147              assign string (source, dest)
 4148              drop (source);  drop (dest)
 4149              %return
 4150           %finish
 4151           %if dest_type = records %start
 4152              slen = 0
 4153              slen = var(source_format)_length %if source_type = records
 4154              dlen = var(dest_format)_length
 4155              %if dlen = 0 = slen %start;      ! Eh ???
 4156                 clear (source) %if source_type = records
 4157                 clear (dest)
 4158                 error ('*', "record format not specified")
 4159              %else
 4160                 %if dlen = 0 %start;          ! rec = record(n)
 4161                    work = slen
 4162                 %else %if slen = 0;           ! rec = 0
 4163                    work = dlen
 4164                 %else
 4165                    error ('*', "record format mismatch??") %if dlen # slen
 4166                    work = slen
 4167                 %finish
 4168                 abort (0) %if work < 0;       ! more than 1/2 a VM ?????
 4169                 total = work
 4170                 work = rem (total, 16_FFFF)
 4171                 total = (total-work)//16_FFFF;! No of blocks left
 4172                 work = 16_FFFF %and total = total-1 %if work = 0
 4173                 len == literal(work);  stp = stp-1
 4174                 shape up (short+integers, len)
 4175                 %if dest_flags&indexed # 0 %and
 4176+                    dest_iscale = 1 %and total # 0 %start
 4177                    ! If MOVCn required, context is BYTE,
 4178                    ! so fool ADDRESS.
 4179                    dest_length = 1
 4180                 %finish
 4181                 address (dest);  dest_type = integers
 4182                 %if source_type = records %start
 4183                    op = movc3
 4184                    %if total # 0 %start
 4185                       op = op!no short
 4186                       %if source_flags&indexed # 0 %and
 4187+                          source_iscale = 1 %start
 4188                          ! same fiddle as above
 4189                          source_length = 1
 4190                       %finish
 4191                    %finish
 4192                    address (source);  source_type = integers
 4193                    string3 (op, len, source, dest)
 4194                    clear (source)
 4195                    op = 1;                    ! mark record move
 4196                 %else;                        ! rec = 0
 4197                    work = scale type (work)
 4198                    %if work >= 0 %and total = 0 %start
 4199                       ! Can use short form
 4200                       plant1 (clrl+work, dest)
 4201                    %else
 4202                       plant5 (movc5, zerov, gla work, zerov, len, dest)
 4203                    %finish
 4204                    op = 0;                    ! marks rec=0
 4205                 %finish
 4206                 clear (dest)
 4207                 %if total > 0 %start;         ! more to do...
 4208                    %if total # 1 %start;      ! need a loop
 4209                       count == literal(total);  stp = stp - 1
 4210                       load (count, r10)
 4211                       loop ca = ca
 4212                    %finish
 4213                    len_disp = -1;             ! => 16_FFFF in OPERAND
 4214                    dest_base = r3;  dest_disp = 0;  dest_form = v in s
 4215                    dest_flags = 0;  claim (r3)
 4216                    %if op # 0 %start;         ! rec move
 4217                       source_base = r1; source_disp = 0; source_form = v in s
 4218                       source_flags = 0; claim (r1)
 4219                       plant3 (movc3, len, source, dest)
 4220                    %else
 4221                       plant5 (movc5, zerov, gla work, zerov, len, dest)
 4222                    %finish
 4223                    %if total # 1 %start
 4224                       plant1 (sobgtr, count)
 4225                       put number byte (loop ca-(ca+1));    ! byte offset
 4226                       release (r10)
 4227                       drop (count)
 4228                    %finish
 4229                 %finish
 4230                 drop (len)
 4231              %finish
 4232              drop (dest)
 4233              drop (source)
 4234              %return
 4235           %finish
 4236  
 4237           oper = source_oper
 4238           %if oper # 0 %start
 4239              %if assop = 2 %start
 4240                 %if dest_type&integers # 0 %start
 4241                    iovf off
 4242                 %finish
 4243              %finish
 4244              %if oper < add %start;        !unary
 4245                 %if oper = not %and dest_type&real bit # 0 %start
 4246                    ! Real = \integer
 4247                    load (source, any)
 4248                    source_oper = 0
 4249                 %else
 4250                    op = mnegl;  op = mcoml %if oper = not
 4251                    source_oper = 0
 4252                    equate (dest, source, 0)
 4253                    %if dest_type = source_type # byte+integers %start
 4254                       %if same (source, dest) %start
 4255                          address (dest)
 4256                          source = dest;  claim (source_base)
 4257                       %else
 4258                          address (source);  address (dest)
 4259                       %finish
 4260                       plant2 (op+dest_type&7, source, dest)
 4261                       clear (source)
 4262                       drop (source);  drop (dest)
 4263                       iovf on
 4264                       %return
 4265                    %finish
 4266                    source_oper = oper
 4267                 %finish
 4268              %else
 4269                 op = op map(oper)
 4270                 %if op # 0 %start;            !3-op possible
 4271                    w == source_link
 4272                    source_oper = 0
 4273                    wt = w_type;  st = source_type;  dt = dest_type
 4274                    %if (dt!wt!st)&real bit = 0 %start
 4275                       ! Massage integer constants to permit 3-ops
 4276                       %if const (w) %and
 4277+                          fits (w_disp, dt) %start
 4278                          w_type = dt %and wt = dt %if st = dt
 4279                       %else %if const (source) %and
 4280+                                fits (source_disp, dt)
 4281                          source_type = dt %and st = dt %if wt = dt
 4282                       %finish
 4283                    %finish
 4284                    %unless dt # st = wt %start
 4285                       equate (dest, source, 0)
 4286                       equate (dest, w, 0)
 4287                       %if source_type = dest_type = w_type %start
 4288                          %if same (dest, source) %start
 4289                             address (dest);  source = dest
 4290                             claim (source_base)
 4291                             address (w)
 4292                          %else %if same (dest, w)
 4293                             address (dest);  w = dest
 4294                             claim (w_base)
 4295                             address (source)
 4296                          %else %if same (source, w);   ! a = b + b
 4297                             address (source);  w = source
 4298                             claim (w_base)
 4299                             address (dest)
 4300                          %else
 4301                             address (source)
 4302                             address (dest)
 4303                             address (w)
 4304                          %finish
 4305                          iovf off %if dest_type = byte+integers
 4306                          plant3 (op+dest_type&7, w, source, dest)
 4307                          iovf on
 4308                          clear (source);  clear (w)
 4309                          drop (source);  drop (dest);  drop (w)
 4310                          %return
 4311                       %finish
 4312                    %finish
 4313                    source_oper = oper
 4314                 %else
 4315                    drop (dest) %and %return %if simple shift (source, dest)
 4316                 %finish
 4317              %finish
 4318              load (source, any) %if source_oper # 0
 4319           %finish
 4320           ! Prevent trouble with "byte = intarray(n)": would generate MOVB
 4321           !   but with source indexed, should be appropriate source length op.
 4322           load (source, any) %if source_flags&indexed # 0 %and
 4323+                                 source_type # byte+integers = dest_type
 4324           shape up (dest_type, source) %if assop = 2 %and const (source)
 4325           address (dest)
 4326           source_type = dest_type %if source_form = constant %and
 4327+                                      dest_type&integers # 0
 4328           op = (source_type&7)*8+7*8
 4329           op = movl %if source_type = dest_type %or zero (source)
 4330           op = op + dest_type&7
 4331           %if source_form = av in s %or source_form = av in rec %start
 4332              %if dest_type # integers %start
 4333                 load (source, any)
 4334              %else
 4335                 source_form = source_form-1;  op = moval
 4336              %finish
 4337           %finish
 4338           address (source)
 4339           scale index (op, source)
 4340           plant2 (op, source, dest)
 4341           clear (source);  clear (dest)
 4342           drop (source);  drop (dest)
 4343           iovf on
 4344        %end
 4345  
 4346        %routine  LRD (%record(stackfm) %name v, %integer reg)
 4347           !load, release and drop
 4348           load (v, reg)
 4349           release (v_base);             !reg could be any!!!!!
 4350           drop (v)
 4351        %end
 4352  
 4353        %routine  SET STATUS
 4354           ! This is the top level - load a 'success' result
 4355           ! into R0 for the CLI's benefit (return pending).
 4356           %record(stackfm) %name  res
 4357           %return %if uncond jump = ca
 4358           res == literal(1);  stp = stp - 1
 4359           lrd (res, r0)
 4360        %end
 4361  
 4362        %routine  SET RESULT (%record(stack fm) %name v, %integer mode)
 4363           %integer  reg
 4364           amap (v) %if mode = 'M';                     !a map
 4365           %if gvar_type&(strings!records) # 0 %and mode = 'V' %start
 4366              ! Result of string/record function - goes via
 4367              ! (hidden) first parameter..
 4368              lstack (64);                               ! disp of result addr
 4369              lhs_form = a in s
 4370              %if gvar_type&records # 0 %start
 4371                 lhs_type = records;  lhs_format = gvar_format
 4372                 dstack (v);  assign (1)
 4373              %else
 4374                 lhs_type = strings;  lhs_length = gvar_length
 4375                 stp = stp - 1
 4376                 assign string (v, lhs)
 4377                 drop (lhs)
 4378              %finish
 4379              drop (v)
 4380           %else
 4381              reg = r0
 4382              reg = fpr0 %if gvar_type&real bit # 0 %and mode = 'V'
 4383              lrd (v, reg)
 4384           %finish
 4385        %end
 4386  
 4387        %routine  RETURN
 4388           %return %if uncond jump = ca
 4389           put code (opcode(ret&255))
 4390           uncond jump = ca
 4391        %end
 4392  
 4393        %routine  RECORD SELECT
 4394           %integer  n
 4395           n = getword;  set lhs
 4396           vstack (var(var(lhs_format)_extra-n))
 4397           set both
 4398           stp = stp - 1
 4399           monitor (lhs, "Rec sel in") %if diag&8 # 0
 4400           %if lhs_flags&indexed # 0 %and
 4401+              (lhs_flags&xdefer # 0 %or
 4402+               lhs_form = a in s %or lhs_form = a in rec) %start
 4403              ! address calc incomplete
 4404              address (lhs)
 4405              %if lhs_flags&xdefer # 0 %and rhs_disp # 0 %start
 4406                 amap (lhs)
 4407                 load (lhs, any)
 4408                 lhs_form = v in s
 4409              %finish
 4410           %finish
 4411           %if lhs_form = v in s %or lhs_form = v in rec %start
 4412              rhs_disp = rhs_disp+lhs_disp
 4413              lhs_form = lhs_form - v in s + rhs_form
 4414              rhs_mantissa = rhs_mantissa + lhs_disp;   ! For arrays in records
 4415           %else %if lhs_form = a in s %or lhs_form = a in rec
 4416              %if lhs_form = a in s %and activity(lhs_base) < 0 %start
 4417                 lhs_extra = lhs_disp
 4418                 lhs_form  = rhs_form + rec mod
 4419              %else
 4420                 lhs_form = lhs_form - 2;  lhs_type = integers
 4421                 load (lhs, any)
 4422                 lhs_form = rhs_form
 4423              %finish
 4424           %else %if lhs_form <= v in r
 4425              lhs_form = rhs_form
 4426           %else
 4427              abort (45)
 4428           %finish
 4429           lhs_disp     = rhs_disp
 4430           lhs_type     = rhs_type
 4431           lhs_length   = rhs_length
 4432           lhs_format   = rhs_format
 4433           lhs_header   = rhs_header
 4434           lhs_mantissa = rhs_mantissa
 4435           drop (rhs)
 4436           monitor (lhs, "Rec sel out") %if diag&8 # 0
 4437        %end
 4438  
 4439        %routine  ARRAY REF (%integer mode)
 4440           !mode = 0 -     last subscript (or only)
 4441           !     = 1 - not last subscript
 4442           %record(stackfm) %name  a, ind
 4443           %integer  type, len, rlen, c, form, x, idrop
 4444           %integer  aname, icon, ival, hbase, hdisp
 4445  
 4446           %if mode # 0 %start;            !multi-dim
 4447              set both
 4448              %if lhs_oper = 0 %start
 4449                 lhs_oper = 1;  lhs_link == null
 4450              %finish
 4451              address (rhs);                !index
 4452              rhs_link == lhs_link;  lhs_link == rhs
 4453              stp = stp - 1
 4454              %return
 4455           %finish
 4456  
 4457           a   == stacked(stp-1)
 4458           ind == stacked(stp);    idrop = 1; ! index still stacked
 4459           %if diag&8 # 0 %start
 4460              monitor (a, "Array base")
 4461              monitor (ind, "Array index")
 4462           %finish
 4463  
 4464           rlen = a_length;    type = a_type
 4465           form = a_form&15;   aname = a_form&arrayname bit
 4466           a_type = integers;  a_form = v in s
 4467           %if form >= v in rec %start;   ! Array or arrayname in record
 4468              form = form - 3
 4469              a_form = v in rec
 4470           %finish
 4471  
 4472           ! remember where header is - may be needed
 4473           %if a_header > 0 %start
 4474              hbase = gla;  hdisp = a_header
 4475           %else
 4476              hbase = a_base;  hdisp = a_disp
 4477           %finish
 4478  
 4479           %if a_oper = 0 %start;    ! 1-dim
 4480              ! constant index?
 4481              icon = 0;  icon = 1 %and ival = ind_disp %if const (ind)
 4482              ! sort out length of actual elements of array (may be %namearray)
 4483              len = rlen;  len = 4 %if form = a in s
 4484              ! change A into a descriptor for the zeroth element
 4485              %if a_form = v in rec %start
 4486                 %if aname = 0 %start;     ! array in record
 4487                    %if a_mantissa = 0 %start
 4488                       ! ie addr(A(0)) = addr(record)
 4489                       a_form = a in s;  a_disp = a_extra
 4490                    %else
 4491                       a_disp = a_extra;  a_form = v in s
 4492                       load (a, any)
 4493                       a_form = v in s;  a_disp = a_mantissa
 4494                    %finish
 4495                 %else;                    ! arrayname in record
 4496                    a_form = a in rec
 4497                    address (a)
 4498                    hbase = a_base;  hdisp = a_disp;  ! Will have changed
 4499                 %finish
 4500              %else;                       ! v in s
 4501                 %if a_header = -1 %start
 4502                    a_form = a in s;       ! for arrayname or header complete
 4503                 %else
 4504                    a_disp = a_mantissa
 4505                    a_form = v in s
 4506                 %finish
 4507              %finish
 4508  
 4509              %if control&arr check # 0 %start; ! Check array index
 4510                 load (ind, r1)
 4511                 lstack (hdisp); lhs_base = hbase
 4512                 lhs_xno = a_xno;  stp = stp - 1
 4513                 %if a_header < 0 %start;       ! Header complete: load in 1 go
 4514                    hazard (r2); hazard (r3)
 4515                    plant2 (movq, lhs, regv(r2))
 4516                 %else
 4517                    lhs_disp = lhs_disp + 4;    ! point at dope vector pointer
 4518                    load (lhs, r3);             ! load it: r3 -> dope vector
 4519                    amap (a);  load (a, r2);    ! r2 is zero address
 4520                    release (r2);  release (r3)
 4521                 %finish
 4522                 drop (lhs)
 4523                 release (r1)
 4524                 prim (aref)
 4525                 claim (r1);  a_base = r1;  a_disp = 0
 4526              %else;                         ! No checking
 4527                 aname = 0;  aname = 1 %if a_form = a in s
 4528                 %if aname = 0 %and (ind_oper = add %or ind_oper = sub) %and
 4529+                    const (ind_link)  %start
 4530                    !  a(j+const) -> a(j) ++ const
 4531                    c = ind_link_disp;  c = -c %if ind_oper = sub
 4532                    a_disp = a_disp + c * len
 4533                    drop (ind_link);   ind_oper = 0
 4534                 %finish
 4535                 %if icon # 0 %and ival = 0 %and aname # 0 %and
 4536+                    (form = v in s %or activity(a_base) < 0) %start
 4537                    ! aname(0) -> @aname
 4538                    %if form = v in s %start
 4539                       form = a in s
 4540                    %else
 4541                       form = a in rec;  a_extra = a_disp;  a_disp = 0
 4542                    %finish
 4543                 %else
 4544                    %if len = 0 %start;    ! %record/%string(*) %arraynames
 4545                       !get size from dope vector
 4546                       lstack (hdisp+4);   ! disp of dope vector pointer
 4547                       lhs_base = hbase
 4548                       lhs_xno = a_xno
 4549                       load (lhs, any)
 4550                       lhs_form = v in s;  lhs_disp = 12;  ! size l/word in dv.
 4551                    %else
 4552                       cstack (len)
 4553                    %finish
 4554                    operate (mul)
 4555                    amap (a);  operate (add)
 4556                    vmap (a)
 4557                    %if form  = a in s %then form = a_form + 2 %c
 4558+                                      %else form = a_form
 4559                    idrop = 0;                  ! ind will have been dropped
 4560                 %finish
 4561              %finish
 4562              stp = stp - 1 %and drop (ind) %if idrop # 0;   ! Not already done
 4563           %else;              ! multi dim - uses the perm
 4564              stp = stp - 1
 4565              a_oper = 0
 4566              ! expend stacked indices
 4567              address (ind)
 4568              push (ind, x)
 4569              %cycle
 4570                 ind == a_link;  a_link == ind_link
 4571                 push (ind, x)
 4572              %repeat %until a_link == null
 4573              address (a)
 4574              hazard (r2);  hazard (r3)
 4575              plant2 (movq, a, regv(r2))
 4576              prim (arefn)
 4577              claim (r1);  a_base = r1;  a_disp = 0;  a_form = v in s
 4578           %finish
 4579           a_form = form
 4580           a_xno = 0 %unless a_base = pc
 4581           a_type = type;  a_length = rlen
 4582           monitor (a, "Array ref") %if diag&8 # 0
 4583        %end
 4584  
 4585     !comparison processing
 4586  
 4587        %routine  TEST ZERO (%record(stackfm) %name v)
 4588           !check v against zero
 4589           %record(stackfm) %name w
 4590           %integer d, op
 4591           unsigned = 0
 4592           %if v_oper = bic %and v_link_form = constant %start
 4593              d = \v_link_disp
 4594              drop (v_link);  v_oper = 0
 4595              op = bitl
 4596              %if  v_type = byte+integers %start
 4597                 %if d&(\255) # 0 %then load (v, any) %else op = bitl+byte
 4598              %else %if v_type = short+integers
 4599                 %if d&16_ffff0000 # 0 %then load (v, any) %else op = bitl+short
 4600              %finish
 4601              address (v)
 4602              w == literal(d);  stp = stp-1
 4603              w_type = v_type
 4604              plant2 (op, v, w)
 4605              drop (w)
 4606           %else
 4607              address (v)
 4608              unsigned = 8 %if v_type = byte+integers
 4609              plant1 (tstl+v_type&7, v)
 4610           %finish
 4611           clear (v)
 4612        %end
 4613  
 4614        %routine  COMPARE (%record(stackfm) %name left, right, %integer mod)
 4615           ! set the cc from left and right
 4616           %integer  work
 4617           %record(stackfm) %name  len, temp
 4618  
 4619           %routine  CHECK (%record(stackfm) %name a, b)
 4620              ! a is a constant string
 4621              %record(stackfm) len
 4622              len = 0
 4623              len_disp = a_format
 4624              %if len_disp = 0+1 %start;          !null
 4625                 b_type = byte+integers
 4626                 test zero (b)
 4627              %else
 4628                 address (b)
 4629                 string3 (cmpc3, len, a, b)
 4630              %finish
 4631           %end
 4632  
 4633           %if zero (right) %start
 4634  !**************  rubbish            %if mod # 0 %and left_oper = sub %start
 4635  !**************  rubbish               ! a - b comp 0 => a comp b
 4636  !**************  rubbish               drop (right);  right == left_link;  left_oper = 0
 4637  !**************  rubbish            %else
 4638                 test zero (left);  %return
 4639  !*****************rubbish            %finish
 4640           %finish
 4641           %if zero (left) %start
 4642              %if mod # 0 %and right_oper = sub %start
 4643                 ! 0 comp a - b => b comp a
 4644                 drop (left);   left == right_link;  right_oper = 0
 4645              %else
 4646                 invert = invert!!16
 4647                 test zero (right);  %return
 4648              %finish
 4649           %finish
 4650  
 4651           unsigned = 0
 4652           %if right_type&strings # 0 %start
 4653              %unless '=' # look # '#' %start
 4654                 %if left_format # 0 %start
 4655                    check (left, right);  %return
 4656                 %finish
 4657                 %if right_format # 0 %start
 4658                    check (right, left);  %return
 4659                 %finish
 4660                 string op (cmpc3, left, right);  %return
 4661              %finish
 4662              load (left, r10);  load (right, r2)
 4663              release (r10);  release (r2)
 4664              prim (scomp)
 4665              %return
 4666           %finish
 4667  ! ???? Why the following, if pass1 won't let one compare records????????
 4668           %if left_type = records %or right_type = records %start
 4669              work = var(left_format)_length
 4670              %if work = 0 %and right_type = records %start
 4671                 work = var(right_format)_length
 4672              %finish
 4673              len == literal(work); stp = stp - 1
 4674              len_type = short+integers
 4675              address (left); left_type = integers
 4676              address (right); right_type=integers
 4677              string3 (cmpc3, len, left, right)
 4678              clear (left);  clear (right)
 4679              drop (len)
 4680              %return
 4681           %finish
 4682           address (left);    address (right)
 4683           equate (left, right, 1)
 4684           unsigned = 8 %if left_type = byte+integers
 4685           %if short literal(left) >= 0 %start
 4686              ! faster to have it on the right...
 4687              invert = invert!!16
 4688              temp == right;  right == left;  left == temp
 4689           %finish
 4690           plant2 (cmpl+left_type&7, left, right)
 4691           clear (left);  clear (right)
 4692        %end
 4693  
 4694        %routine  COMPARE ARRAYNAMES (%record(stack fm) %name lhs, rhs)
 4695           lhs_form = lhs_form&15;  rhs_form = rhs_form&15
 4696           address (lhs);  address (rhs)
 4697           plant2 (cmpd, lhs, rhs)
 4698           clear (lhs); clear (rhs)
 4699        %end
 4700  
 4701        %routine  SET CC
 4702           %const %byte %array cc  (1:6) =  4,   8, 8+2+1, 8+1, 8+2, 4+2
 4703           %const %byte %array cmap(1:6) = '=', '<', '(',  '>', ')', '#'
 4704           %record(stackfm) %name pos, one, temp
 4705           %integer sym, code, r
 4706  
 4707           get (sym)
 4708           code = 0
 4709           %for r = 1,1,6 %cycle
 4710              code = r %and %exit %if cmap(r) = sym
 4711           %repeat
 4712           abort (34) %if code = 0
 4713           code = cc(code)
 4714           set both
 4715           %if code&1 # 0 %start;                  !swop first
 4716              temp == lhs;  lhs == rhs;  rhs == temp
 4717           %finish
 4718           compare (lhs, rhs, 1);  stp = stp-2
 4719           drop (lhs);  drop (rhs)
 4720           r = register (0)
 4721           temp == regv (r)
 4722           claim (r)
 4723           plant1 (movpsl, temp)
 4724           plant2 (mcoml, temp, temp) %if code&2 # 0;  !invert it
 4725           pos == literal(code&(4!8));  stp = stp - 1
 4726           one == literal(1);           stp = stp - 1
 4727           drop (pos); drop (one)
 4728           plant4 (extzv, pos, one, temp, temp)
 4729           dstack (temp)
 4730        %end
 4731  
 4732        %routine  FOR
 4733           ! compile a %for clause
 4734           %integer  lab, err, fixed, old control
 4735           %integer  sc, sv, ic, iv, lc, lv, x
 4736           %record(stackfm) %name  cont, init, incr, last
 4737  
 4738           %routine  STAB (%record(stack fm) %name v, %integername con, val)
 4739              %record(stack fm) %name  w
 4740              con = 0
 4741              %if const (v) %start
 4742                 con = 1
 4743                 val = v_disp
 4744              %else
 4745                 w == temp(4)
 4746                 dstack (v);   v = w
 4747                 assign (1)
 4748              %finish
 4749           %end
 4750  
 4751           stp = stp - 4
 4752           cont == stacked(stp+1)
 4753           incr == stacked(stp+2)
 4754           last == stacked(stp+3)
 4755           init == stacked(stp+4)
 4756  
 4757           abort (20) %if cont_type&integers = 0
 4758           %if cont_type # integers %start
 4759              error ('*', "only %integer %for-loop variables permitted")
 4760              cont_type = integers
 4761           %finish
 4762           stab (incr, ic, iv)
 4763           stab (last, lc, lv)
 4764           sc = 0;  sc = 1 %and sv = init_disp %if const (init)
 4765           %unless activity(cont_base) < 0 %and cont_form = v in s  %and
 4766+                  cont_flags = 0 %start
 4767              ! Can't use cv directly
 4768              amap (cont);   stab (cont, x, x);  cont_form = a in s
 4769           %finish
 4770           fixed = sc&ic&lc;                ! constant bounded loop?
 4771           dstack (cont);                   ! to assign to
 4772           %if fixed = 0 %and control&for check # 0 %start
 4773              ! Need perm call
 4774              dstack (init);  pop lhs;  lrd (lhs, r1)
 4775              dstack (incr);  pop lhs;  lrd (lhs, r2)
 4776              dstack (last);  pop lhs;  lrd (lhs, r3)
 4777              prim (for test);              ! returns init-incr
 4778              dstack (regv(r0))
 4779              claim (r0)
 4780           %else %if fixed # 0
 4781              ! Fixed loop - test for legality
 4782              sv = sv - iv
 4783              err = 0
 4784              %if iv = 0 %start
 4785                 err = 1 %unless sv = lv;   ! x, 0, y
 4786              %else
 4787                 %if iv > 0 %start
 4788                    err = 1 %if sv > lv
 4789                 %else
 4790                    err = 1 %if sv < lv
 4791                 %finish
 4792                 err = 1 %if rem (lv-sv, iv) # 0
 4793              %finish
 4794              error ('*', "%for loop cannot terminate") %if err # 0
 4795              cstack (sv)
 4796           %else
 4797              dstack (init);  dstack (incr);  operate (sub)
 4798           %finish
 4799           assign (1)
 4800           lab = getword;  define label (lab)
 4801  
 4802           ! No need to check assigned from here on
 4803           old control = control
 4804           control = control & (\ass check)
 4805  
 4806           ! %exit %if cont = last
 4807           compare (cont, last, 0)
 4808           jump to (lab+1, 1, 1)
 4809  
 4810           ! cont = cont + incr
 4811           dstack (cont);  dstack (cont);  dstack (incr)
 4812           operate (add);   assign (1)
 4813  
 4814           control = old control
 4815  
 4816           drop (cont);  drop (incr);  drop (init);  drop (last)
 4817        %end
 4818  
 4819  
 4820     !procedure processing
 4821  
 4822        %routine  PUSH (%record(stackfm) %name  t, %integer %name n)
 4823           %integer op, mop, old op
 4824           %record(stackfm) %name w
 4825           %record(stackfm) ww
 4826  
 4827           monitor (t, "Push") %if diag&16 # 0
 4828  
 4829           op = pushl;  mop = -1
 4830           %if t_oper # 0 %start;           !arraynames or %name
 4831              old op = t_oper;  t_oper = 0
 4832              %if old op = 2 %start;        !general name
 4833                 push (literal(t_type<<24+t_length), n);  stp = stp-1
 4834                 t_form = t_form & 15
 4835                 address (t)
 4836                 amap (t)
 4837              %else %if old op = 1
 4838                 move arrayname (t, spv)
 4839                 n = n + 2; %return
 4840              %else
 4841                 t_form = v in s;  mop = movq
 4842                 drop (t)
 4843              %finish
 4844           %else %if t_type = integers
 4845              address (t) %if t_form # av in s
 4846              %if t_form = constant %and -64 <= t_disp < 0 %start
 4847                 ! Can use mcoml,mnegl -  let PLANT2 fix it
 4848                 mop = movl;
 4849                 drop (t);  n = n - 1
 4850              %finish
 4851           %else
 4852              %if t_type&(records!strings) # 0 %start
 4853                 %if t_type = records %start
 4854                    w == temp(var(t_format)_length)
 4855                    w_type = records;  w_format = t_format
 4856                    dstack (w);  dstack (t);  assign (1)
 4857                    stp = stp - 1
 4858                    drop (t);  t == w
 4859                 %else %if t_type = strings;   !not already in wk strg
 4860                    w == work string;  stp = stp-1
 4861                    ww = w
 4862                    assign string (t, w);  drop (t)
 4863                    t == w;  t = ww
 4864                 %finish
 4865                 t_type = integers;  op = pushal
 4866              %else %if t_type&real bit # 0
 4867                 address (t)
 4868                 drop (t);  clear (t);  mop = movd
 4869                 %if t_type = reals %start
 4870                    n = n - 1; mop = movf
 4871                 %finish
 4872              %else %if t_type = long+integers
 4873                 mop = movq;  address (t);  drop (t)
 4874              %else
 4875                 address (t);  clear (t);  drop (t)
 4876                 mop = t_type&7*8+7*8
 4877                 n = n - 1;                !only 1 longword
 4878              %finish
 4879           %finish
 4880           %if mop = -1 %start
 4881              %if t_form = av in s %start
 4882                 op = pushal;  t_form = v in s
 4883              %finish
 4884              scale index (op, t)
 4885              plant1 (op, t) %if op # 0
 4886              clear (t);  drop (t)
 4887           %else
 4888              scale index (mop, t)
 4889              plant2 (mop, t, spv)
 4890              n = n + 1;          !an extra param
 4891           %finish
 4892           n = n + 1
 4893        %end
 4894  
 4895        %routine  CALL (%record(stackfm) %name v)
 4896           !call procedure 'v'
 4897           %integer  reg, n, disp, type, form, pn, pa
 4898           %record(stackfm) %name  t, p, w
 4899           %record(stackfm)  ec
 4900           %switch  pri (1 : 31)
 4901           %const %byte %array params (1 : 31) =
 4902+             1(17), 2(2), 0(3), 1, 1(4), 0, 0, 2, 2
 4903           %const %byte %array  ptype (2 : 8) =
 4904+             byte+integers, short+integers,
 4905+             integers, strings, records,
 4906+             reals, reall
 4907           %const %byte %array  plen (2 : 8) =
 4908+             1, 2, 4, 0, 0, 4, 8
 4909  
 4910           monitor (v, "Call") %if diag&16 # 0
 4911           type = v_type;  form = v_form&15
 4912           disp = v_disp
 4913           pn   = v_mantissa
 4914           %if pn # 0 %start;                  ! %PRIM
 4915              pa = params(pn);                 ! #parameters
 4916              %if pa > 0 %start
 4917                 t == v_link;   t_oper = 0
 4918                 %if pa = 2 %start
 4919                    rhs == t;                  ! 2nd parameter heads list
 4920                    t == t_link
 4921                    t_oper = 0
 4922                 %finish
 4923                 dstack (t);   set lhs
 4924                 drop (t)
 4925              %finish
 4926              drop (v) %if pn < 23;            ! No actual external ref
 4927              -> pri (pn)
 4928        pri(1):                                !addr
 4929              %if lhs_form = 15 %start;        ! of label?
 4930                 n = register (0);  claim (n)
 4931                 entry mask = entry mask ! reg mask (n)
 4932                 put code (16_9E);     !movab
 4933                 flush code
 4934                 define reference (lhs_disp, dir pref)
 4935                 put (obj call);  ca = ca + 2;   !assume short
 4936                 put long (lhs_disp)
 4937                 put number byte (16_50+n-1); !Rn
 4938                 lhs_base = n;  lhs_disp = 0; lhs_xno = 0
 4939                 lhs_type = integers;  lhs_form = v in r
 4940              %else
 4941  !!!!           error ('*' "cannot take address of...") %if .. ??
 4942                 amap (lhs)
 4943              %finish
 4944              %return
 4945        pri(2):                                !byte
 4946        pri(3):                                !short
 4947        pri(4):                                !integer
 4948        pri(5):                                !string
 4949        pri(6):                                !record
 4950        pri(7):                                !real
 4951        pri(8):                                !longreal
 4952              load (lhs, any) %if pn = 5 %and lhs_flags&indexed # 0
 4953              vmap (lhs)
 4954              lhs_type   = ptype(pn)
 4955              lhs_length = plen(pn)
 4956              lhs_format = 0;                  ! For strings/records
 4957              %return
 4958        pri(9):                                !int
 4959        pri(10):                               !intpt
 4960              address (lhs)
 4961              n = register (0);  claim (n)
 4962              plant2 (11*8-4*8+lhs_type&7*8+6*(10-pn), lhs, regv(n))
 4963              release (lhs_base)
 4964              lhs_base = n
 4965              lhs_form = v in r;  lhs_disp = 0; lhs_xno = 0
 4966              lhs_type = integers;  lhs_length = 4
 4967              %return
 4968        pri(11):                               !read ch
 4969        pri(12):                               !read symbol
 4970              %if lhs_type&(integers!strings) = 0 %start
 4971                 error ('*', "invalid parameter to READ SYMBOL/CH")
 4972                 lhs_type = integers
 4973              %finish
 4974              prim (rch+pn-11)
 4975              abort (47) %if lhs_oper # 0
 4976              %if lhs_type&strings # 0 %start
 4977                 %if lhs_form # v in s %or lhs_flags # 0 %start
 4978                    amap (lhs);  load (lhs, any)
 4979                    lhs_form = v in s;  lhs_type = byte+integers
 4980                 %finish
 4981                 lhs_flags = auto i %if activity(lhs_base) = 1
 4982                 lhs_type = byte + integers;  lhs_length = 1
 4983                 dstack (lhs);  cstack (1);  assign (1)
 4984                 claim (lhs_base)
 4985                 %if lhs_flags = auto i %start
 4986                    lhs_flags = 0
 4987                 %else
 4988                    lhs_disp = lhs_disp + 1
 4989                 %finish
 4990              %finish
 4991              w == regv(r0);  claim (r0);  dstack (w)
 4992              assign (1)
 4993              %return
 4994        pri(20):                               !skip item
 4995              pn = 22;                         !=skip symbol
 4996        pri(21):                               !skip ch
 4997        pri(22):                               !skip symbol
 4998              prim (rch+pn-21)
 4999              %return
 5000        pri(13):                               !printch
 5001        pri(14):                               !print symbol
 5002              stp = stp - 1
 5003              lrd (lhs, r0)
 5004              prim (pch+pn-13)
 5005              %return
 5006        pri(15):                               !tostring
 5007              stp = stp-1
 5008              w == temp(2);  w_type = byte+integers
 5009              dstack (w);  dstack (w)
 5010              dstack (lhs);  drop (lhs)
 5011              set both;  lhs_disp = lhs_disp + 1
 5012              assign (1)
 5013              cstack (1)
 5014              assign (1)
 5015              set lhs;  lhs_type = strings;  lhs_format = 2
 5016              %return
 5017        pri(18):                                 !charno
 5018              %if control&str check # 0 %start
 5019                 load (lhs, r0);  release (r0);  ! string address
 5020                 lrd  (rhs, r1);                 ! character #
 5021                 prim (char num)
 5022                 claim (r0)
 5023                 lhs_form = v in s;  lhs_length = 1
 5024                 lhs_type = byte+integers
 5025                 %return
 5026              %finish
 5027              dstack (rhs);   drop (rhs)
 5028              operate (add);  set lhs
 5029        pri(17):                                 !length
 5030              vmap (lhs)
 5031              lhs_type = byte+integers
 5032              lhs_length = 1
 5033              %return
 5034        pri(19):                                 !rem
 5035              dstack (rhs);  drop (rhs)
 5036              operate (remy)
 5037              set lhs
 5038        pri(16):                                 !float
 5039              %return;                           ! already done by ASSIGN!
 5040        pri(24):                                 !PUT
 5041        pri(25):                                 !PUT WORD
 5042        pri(26):                                 !PUT LONG
 5043        pri(27):                                 !GET (%integername b)
 5044        pri(30):                                 !PUT BLOCK
 5045        pri(31):                                 !GET BLOCK
 5046              stp = stp - 1;                     ! no result
 5047              lrd (lhs, r0)
 5048              lrd (rhs, r1) %if pn >= 30
 5049              hazard (reg) %for reg = r0, 1, r10
 5050              v_form = v in s;  plant1 (jsb, v);  drop (v)
 5051              %return
 5052        pri(28):                                 !GET WORD ()
 5053        pri(29):                                 !GET LONG ()
 5054              hazard (reg) %for reg = r0, 1, r10
 5055              v_form = v in s;  plant1 (jsb, v);  drop (v)
 5056              dstack (regv(r0));  claim (r0);    ! The result
 5057              %return
 5058        pri(23):                                 !printstring
 5059              ! main point of this is to prevent loading
 5060              ! parameter into work string..
 5061              ! (pity if it's there already!)
 5062              stp = stp - 1
 5063              v_link == lhs;  lhs_link == null
 5064              %if lhs_type = strings %start
 5065                 ! Not already in work string - hurrah!
 5066                 address (lhs)
 5067                 test assigned (lhs)
 5068                 amap (lhs);                     ! now integer (av in s)
 5069              %finish
 5070           %finish
 5071  
 5072           n = 0
 5073           t == v_link
 5074           %while t ## null %cycle
 5075              p == t_link
 5076              push (t, n)
 5077              t == p
 5078           %repeat
 5079           %if v_type&(strings!records) # 0 %and
 5080+              v_form&15 = v in r    %start;          !stringfn
 5081              %if v_type&strings # 0 %then p == work string %c
 5082+                                    %else p == temp(var(v_format)_length)
 5083              p_type = integers
 5084              plant1 (pushal, p)
 5085              p_type = strings!4;      !already in a work string
 5086              p_type = records %if v_type = records
 5087              p_format = v_format
 5088              v_type = 0;  type = 0
 5089              n = n + 1;                !an extra hidden parameter
 5090           %finish
 5091           hazard (reg) %for reg = r0, 1, r10
 5092           %if v_base # pc %start;                        !parameter
 5093              v_type = integers;  v_form = v in s
 5094              plant2 (movl, v, regv(r1))
 5095              primep (proc enter)
 5096              plant1 (calls,literal(n)); popdrop
 5097              flush code
 5098              put (obj prim ref); put (proc enter); ca=ca+5
 5099           %else %if v_xno # 0
 5100              ec = v
 5101              ec_form = v in s
 5102              plant2 (calls, literal(n), ec); popdrop
 5103           %else
 5104              plant1 (calls, literal(n));  pop drop;  !second operand set in p3
 5105              flush code
 5106              define reference (disp, dir pref)
 5107              put (obj call);  put long (disp)
 5108              ca = ca + 2;            !assume short
 5109           %finish
 5110           %if type # 0 %start;                        !There's a result
 5111              v_type = type;  v_form = form
 5112              v_base = r0;  v_disp = 0; v_xno = 0
 5113              claim (r0);  dstack (v)
 5114           %finish
 5115           drop (v)
 5116        %end
 5117  
 5118   !sundries
 5119  
 5120        %routine  SET LANGUAGE
 5121           %integer  l
 5122           l = getword;                                !ignore!!!
 5123        %end
 5124  
 5125        %routine  SET DIAG
 5126           %integer  new diag = getword
 5127           diag = new diag&16_3FFF %if new diag&(3<<14) = 2<<14
 5128        %end
 5129  
 5130        %routine  SET CONTROL
 5131           %integer  new control
 5132           ! Don't allow %control to turn on things
 5133           ! which were turned off by command line
 5134           ! (except for record rounding).
 5135           new control = get word
 5136           control = new control & (original control!rec round)
 5137        %end
 5138  
 5139        %routine  LINE BOUND
 5140           ! Perform consistency checks and update line counter
 5141           abort (23) %if stp # 0
 5142           abort (24) %unless using_link == null
 5143           abort (25) %if active regs # 0
 5144           abort (39) %if index regs # 0
 5145           flush code;  current line = getword
 5146           this area = 0;     !return work strings
 5147           line error = 0
 5148           %if diag # 0 %start
 5149              newline
 5150              print string ("Line ");   write (current line, 0)
 5151              newline
 5152           %finish
 5153        %end
 5154  
 5155        %routine  EVENT BLOCK
 5156           %record(stack fm) %name  savesp
 5157           events = getword;  get (discard)
 5158           evlow = getword;                     !finish label
 5159           evno = evno + 1
 5160           savesp == temp(4);  stp = stp - 1
 5161           plant2 (movl, regv(sp), savesp);     !preserve stack
 5162           jump to (evlow, jump, 1);  evlow = last ref
 5163           evep = new tag;  define tag (evep)
 5164           uncond jump = 0
 5165           plant2 (movl, savesp, regv(sp))
 5166           drop (savesp)
 5167        %end
 5168  
 5169        %routine  GENERATE SIGNAL
 5170           cstack (0) %while stp < 2
 5171           cstack (getword)
 5172           pop lhs;  load (lhs, r0);  drop (lhs)
 5173           pop lhs;  load (lhs, r2);  drop (lhs)
 5174           pop lhs;  load (lhs, r1);  drop (lhs)
 5175           release (r0);  release (r1);  release (r2)
 5176           prim (signal)
 5177           uncond jump = ca
 5178        %end
 5179  
 5180        %routine  SET BOUNDS
 5181           set both
 5182           vlb = lhs_disp;  vub = rhs_disp
 5183           pop drop;   pop drop
 5184        %end
 5185  
 5186        %routine  DECLARE ARRAY
 5187           %record(stackfm)  d
 5188           %integer  dim, arrays, sp, j, hdisp, dv
 5189           dim = getword;  get (discard)
 5190           arrays = getword;    !how many
 5191           %if gmode # 0 %start
 5192              parms = parms + arrays
 5193              set both
 5194              vlb = lhs_disp;  vub = rhs_disp
 5195              abort (22) %if vlb > vub+1
 5196              set dope vector (dv)
 5197              stp = stp - 2
 5198              drop (rhs);  drop (lhs)
 5199           %else
 5200              names = names - arrays
 5201              set both
 5202              %if dim = 1 %and const (lhs) %and const (rhs) %and
 5203+                 rhs_disp+1 >= lhs_disp  %start
 5204                 !can alocate in-line - trap array-inside-out at run time..??
 5205                 vlb = lhs_disp;  vub = rhs_disp
 5206                 stp = stp - 2;               !unstack them
 5207                 drop (rhs);  drop (lhs)
 5208                 frame = (frame-arrays*8)&(\3)
 5209                 hdisp = frame
 5210                 dim = 0;                     !for a marker
 5211                 set dope vector (dv)
 5212                 zeroth_base = local
 5213                 dope_disp = dv
 5214                 head_base = local;  head_disp = hdisp
 5215              %else
 5216                 frame = (frame-dim*12)&(\3)-4
 5217                 lstack (frame)
 5218                 pop lhs
 5219                 d = regv(r4);   hazard (r4)
 5220                 plant2 (moval, lhs, d)
 5221                 drop (lhs)
 5222                 d_form = v in s;  d_disp = 4-12
 5223                 %for sp = 2, 2, dim<<1 %cycle
 5224                    lhs == stacked(sp-1)
 5225                    rhs == stacked(sp)
 5226                    claim (r4)
 5227                    lrd (lhs, r1);  lrd (rhs, r2)
 5228                    d_disp = d_disp+12
 5229                    plant2 (movq, regv(r1), d)
 5230                 %repeat
 5231                 prim (set dv)
 5232                 word (dim);  word (data size)
 5233                 stp = 0
 5234                 frame = frame-arrays*8;  hdisp = frame
 5235                 lstack (frame);  pop lhs
 5236                 plant2 (moval, lhs, regv(r3))
 5237                 drop (lhs)
 5238              %finish
 5239           %finish
 5240           %for j = 1, 1, arrays %cycle
 5241              %if gmode # 0 %start
 5242                 parms = parms - 1;  decvar == var(parms)
 5243                 decvar_disp = frame;  decvar_zeroad = frame-vlb
 5244                 decvar_header = ga;  decvar_base = 0
 5245                 glongword (-vlb);  glongword (0)
 5246                 flush gla
 5247                 put (obj reloc); put long (ga-4); put long (dv)
 5248                 frame = frame + vub*data size;       !now the total size
 5249              %else
 5250                 names = names + 1;    decvar == var(names)
 5251                 decvar_base = local;  decvar_header = -1
 5252                 decvar_disp = hdisp;  hdisp = hdisp+8
 5253                 %if dim = 0 %start;                !in-line
 5254                    frame = (frame-vub*data size)&(\7)
 5255                    zeroth_disp = frame-vlb
 5256                    decvar_zeroad = frame-vlb; ! zero address for fast access
 5257                    decvar_header = -2;        ! marker for above detail
 5258                    plant2 (moval, zeroth, head);  head_disp = head_disp+4
 5259                    plant2 (moval, dope, head);  head_disp = head_disp+4
 5260                 %else
 5261                    prim (adec);                     !bumps r3 note
 5262                 %finish
 5263              %finish
 5264           %repeat
 5265        %end
 5266  
 5267        %routine  RESOLVE
 5268           !compile a string resolution
 5269           ! S -> A.(B).C
 5270           %record(stackfm) %name  s, a, b, c
 5271           %integer  flag, sc, bc, acf
 5272  
 5273           %routine  TEST ASSIGNED (%integer base)
 5274              put code (opcode(cmpw&255));      ! cmpw
 5275              put number byte (16_60+base-1);   ! (base)
 5276              put number byte (16_60+gla-1);    ! (gla)
 5277              prim (test ass)
 5278           %end
 5279  
 5280           acf = control&ass check;              ! assignment checking ?
 5281           flag = getword;                       !<cond><a present><c present>
 5282           cstack (0) %if flag&1 = 0;            !c missing
 5283           pop lhs;   c == lhs
 5284           pop lhs;   b == lhs;   bc = b_format
 5285           cstack (0) %if flag&2 = 0;            !a missing
 5286           pop lhs;   a == lhs
 5287           pop lhs;   s == lhs;   sc = s_format
 5288           lrd (a, r0)
 5289           lrd (c, r1)
 5290           lrd (b, r3);  test assigned (r3) %if bc = 0 # acf
 5291           lrd (s, r4);  test assigned (r4) %if sc = 0 # acf
 5292           prim (resolution)
 5293           prim (check resolution) %if flag&4 = 0
 5294        %end
 5295  
 5296        %routine  ADUMP (%integer  times)
 5297           %integer  j
 5298           %for j = times-1, -1, 0 %cycle
 5299              %if owntype = integers %start
 5300                 glongword (ownval)
 5301              %else %if owntype = byte+integers
 5302                 gbyte (ownval)
 5303              %else %if owntype = short+integers
 5304                 gword (ownval)
 5305              %else %if owntype = strings
 5306                 dump string (data size)
 5307              %else %if owntype&real bit # 0
 5308                 glongword (ownval)
 5309                 glongword (mantissa) %if owntype = reall
 5310              %else
 5311                 init gla (data size, 1, 0)
 5312              %finish
 5313           %repeat
 5314        %end
 5315  
 5316        %routine  INITIALISE OWNS
 5317           %integer  aparm = getlong
 5318           %if stp # 0 %start
 5319              pop lhs
 5320              ownval = lhs_disp;  mantissa = lhs_mantissa
 5321              drop (lhs)
 5322              %if owntype&real bit # 0 %and
 5323+                 lhs_type&real bit = 0 %start
 5324                 longreal(addr(ownval)) = ownval
 5325              %finish
 5326           %else
 5327              ownval = 0;  mantissa = 0;  text = ""
 5328           %finish
 5329           %if ownform&array bit # 0 %start
 5330              %if (owntype#strings %or text = "") %and
 5331+                 owntype&realbit = 0 %start
 5332                 %if owntype & integers # 0 %start
 5333                    init gla (aparm, datasize, ownval)
 5334                 %else
 5335                    init gla (aparm*datasize, 1, 0)
 5336                 %finish
 5337              %else
 5338                 adump (aparm)
 5339              %finish
 5340           %else %if otype = 0;                      !const
 5341              decvar_disp = ownval;  decvar_base = 0
 5342              decvar_form = decvar_form-2
 5343           %else
 5344              gfix (3)
 5345              lput (objddef, ga) %if otype >= 3
 5346              decvar_base = gla;  decvar_disp = ga
 5347              adump (1)
 5348              dump diag (1) %if otype # 2
 5349           %finish
 5350        %end
 5351  
 5352        %routine  ZERO OWN
 5353           init gla (vub*datasize, 1, 0)
 5354        %end
 5355  
 5356  
 5357        !======================= main loop =======================
 5358  
 5359     NEXT:
 5360        get (sym) %until sym # nl %and sym # ' '
 5361        code = sym
 5362        abort (21) %unless ' ' < sym <= 127
 5363        %if diag & 2048 # 0 %and sym # 'O' %start
 5364           print string ("Sym='"); print symbol (sym)
 5365           print symbol ('''');  newline
 5366        %finish
 5367        -> c(code)
 5368     c(*): abort (21);           !illegal code item
 5369  
 5370     c('k'):code = 1;       -> testit
 5371     c('t'):code = 6;       -> testit
 5372     c('='):code = 1;       -> jmp
 5373     c('<'):code = 2;       -> jmp
 5374     c('('):code = 3;       -> jmp
 5375     c('>'):code = 4;       -> jmp
 5376     c(')'):code = 5;       -> jmp
 5377     c('#'):code = 6;       -> jmp
 5378     testit:
 5379        plant2 (bitl, literal(1), regv(r0))
 5380        pop drop
 5381     jmp:
 5382        jump to (getword, code+unsigned+invert, 1)
 5383        -> next
 5384  
 5385     c(']'): operate (neg);           !rsh
 5386             operate (rsh);  -> next
 5387     c('['): operate (lsh);  -> next
 5388     c('\'): operate (not);  -> next
 5389     c('U'): operate (neg);  -> next
 5390     c('+'): operate (add);  -> next
 5391     c('-'): operate (sub);  -> next
 5392     c('!'): operate (or);   -> next
 5393     c('%'): operate (xor);  -> next
 5394     c('/'): operate (div);  -> next
 5395     c('X'): operate (exp);  -> next
 5396     c('x'): operate (rexp); -> next
 5397     c('Q'): operate (rdiv); -> next
 5398     c('*'): operate (mul);  -> next
 5399     c('&'): operate (not);
 5400             operate (bic);  ->next
 5401     c(117):                                  ! ++
 5402     c(113): address op (code);   -> next;    ! --
 5403     c('.'): concatenate;         -> next
 5404     c('v'): set modulus;         -> next
 5405  
 5406     c('B'):  code = 0;   -> bjf
 5407     c('F'):  code = 1
 5408     bjf:
 5409        flush code;  set line
 5410        jump to (getword, jump, code)
 5411        -> next
 5412  
 5413     c('J'):
 5414        flush code;  set line
 5415        jump to (-getword, jump, 0)
 5416        -> next
 5417  
 5418     c(':'):
 5419        define label (getword)
 5420        -> next
 5421  
 5422     c('L'):
 5423         n = getword
 5424         names = n %if n > names
 5425         define label (-n);
 5426         -> next
 5427  
 5428     c('T'):
 5429        cstack (-1);     -> res
 5430     c('K'):
 5431        cstack (0)
 5432     c('M'):
 5433     c('V'):
 5434     res:
 5435        pop lhs
 5436        set result (lhs, code)
 5437        ! and...
 5438     c('R'):
 5439        set status %if mainprog = mainrt %and code ='R'
 5440        return
 5441        -> next
 5442  
 5443     c('j'): assign (2);            -> next
 5444     c('S'): assign (1);            -> next
 5445     c('Z'): assign (0);            -> next
 5446     c('p'): assign (-1);           -> next
 5447  
 5448     c('G'): get string (alias);    -> next
 5449     c('$'): define var;            -> next
 5450     c('N'): cstack (getlong);      -> next
 5451     c(''''):get string (text);     -> next
 5452     c('D'): get real;              -> next
 5453  
 5454     c('n'): record select;         -> next
 5455  
 5456     c('a'): array ref (0);         -> next
 5457     c('i'): array ref (1);         -> next
 5458     c('d'): declare array;         -> next
 5459  
 5460     c('O'): line bound;            -> next
 5461  
 5462  
 5463     c('@'):
 5464        v == var(getword)
 5465        spec external (v) %if v_base = pending
 5466        vstack (v)
 5467        -> next
 5468  
 5469     c('~'):
 5470        get (sym)
 5471        %if sym = 'A' %start
 5472           decvar == gvar
 5473           assemble (-2, labs, names)
 5474           -> next
 5475        %finish
 5476        %if sym = 'B' %start
 5477           -> out
 5478        %finish
 5479        abort (36) %unless sym = 'C'
 5480        maxframe = frame %if frame > maxframe
 5481        frame = frame base
 5482        -> next
 5483  
 5484     c('E'): pop lhs;  call (lhs);  -> next
 5485  
 5486     c('C'):
 5487        set both
 5488        %if lhs_form&(arrayname bit!arraybit) # 0 %start
 5489           compare arraynames (lhs, rhs)
 5490           pop drop;  pop drop
 5491           -> next
 5492        %finish
 5493        amap (lhs); amap (rhs)
 5494  
 5495     c('?'):
 5496        set both
 5497        compare (lhs, rhs, 1)
 5498        pop drop;   pop drop
 5499        -> next
 5500  
 5501     c('"'):
 5502        set both;  invert = 16
 5503        load (rhs, any) %if rhs_flags&indexed # 0
 5504        compare (rhs, lhs, 0)
 5505        stp = stp - 1;  lhs = rhs;  drop (rhs)
 5506        claim (lhs_base)
 5507        -> next
 5508  
 5509     c('c'): set cc;                          -> next
 5510     c('f'): for;                             -> next
 5511     c('l'): set language;                    -> next
 5512     c('r'): resolve;                         -> next
 5513     c('A'): initialise owns;                 -> next
 5514     c('I'): zero own;                        -> next
 5515     c('b'): set bounds;                      -> next
 5516     c('y'): set diag;                        -> next
 5517     c('z'): set control;                     -> next
 5518     c('W'): switch jump;                     -> next
 5519     c('_'): define switch label;             -> next
 5520     c('o'): event block;                     -> next
 5521     c('e'): generate signal;                 -> next
 5522     c('w'): machine code;                    -> next
 5523     c('P'): plant;                           -> next
 5524     c('m'): prim (monit);                    -> next
 5525     c('s'): prim (stop);  uncond jump = ca;  -> next
 5526  
 5527     c('{'): gmode = -1
 5528             assemble (gtype, labs, names)
 5529             -> next
 5530  
 5531     c('}'):
 5532        gmode = 0
 5533        -> out %if amode < 0
 5534        define parameters %if names > gstart
 5535        -> out %if amode # 0;          !spec
 5536        frame = 0
 5537        -> next
 5538  
 5539     c('H'):
 5540        decvar == begin;  decvar_disp = new tag
 5541        otype = 0;  spec = 0;  potype = 3
 5542        %if level # 0 %start;      !not initial begin
 5543           cstack (decvar_disp)
 5544           pop lhs;  lhs_base = pc;  lhs_type = 0
 5545           lhs_header = -1;   call (lhs)
 5546           potype = 0
 5547        %finish
 5548        var name = "$GO$";  external name = var name
 5549        assemble (0, labs, names)
 5550        -> next
 5551  
 5552     c(';'):
 5553        %if level # 0 %start
 5554           set status %if mainprog = mainrt
 5555           return
 5556        %finish
 5557        gfix (3)
 5558        define tag (block end tag) %if block end tag # 0
 5559        flush code
 5560        flush gla
 5561  
 5562     OUT:
 5563  
 5564        %if amode = 0 %start
 5565           activity(local) = 0;   !release the base reg
 5566           level = level - 1;  local = base reg(level)
 5567           activity(local) = -1
 5568           frame = frame&(\7)
 5569           %if level >= 0 %start
 5570              select output tank (directives)
 5571              local diags = local diags+1
 5572              put (dir end);  put long (proctype);  put word (entry mask)
 5573              put word (frame);  put word (frame>>16)
 5574              put word (local diags);  put word (diag lines)
 5575              put word (block tag);  put long (ca)
 5576              select output tank (object);  put (obj term)
 5577              put word (events)
 5578              %if events # 0 %start
 5579                 put word (evlow);   put word (evep)
 5580              %finish
 5581           %finish
 5582        %else
 5583           %if amode < 0 %start
 5584              frame = maxframe %if maxframe > frame
 5585              %if amode = -1 %start
 5586                 gvar_length = frame
 5587              %else
 5588                 oldframe = frame
 5589              %finish
 5590           %finish
 5591        %finish
 5592        diag lines  = local lines
 5593        diag size   = diag size+local diags
 5594        frame       = old frame
 5595        last local  = old last local
 5596        uncond jump = old jump
 5597        ca          = old ca
 5598        entry mask  = old mask
 5599        ivbit state = old ivbit
 5600     %end
 5601  
 5602     glongword (16_80808080);  glongword (16_80808080)
 5603     glongword (3+'G'<<8+'L'<<16+'A'<<24);            !gla marker
 5604     glongword (0);                                   !codebase
 5605     glongword (0);                                   !diagbase
 5606     glongword (0);                                   !line base
 5607     gword (0);                                       !null string
 5608     glongword (0)
 5609     glongword (0);                                   !event list
 5610  
 5611     assemble (0, 0, 0);                              !set it going<<<<<<<
 5612  
 5613     gfix (7)
 5614     put (obj end)
 5615  
 5616     select output tank (directives)
 5617     put (dir sizes)
 5618     put long (ga)
 5619     put word (newtag-1)
 5620     put word (specs)
 5621     put word (diag size);  put word (evno)
 5622     put ('*')
 5623  
 5624  
 5625     exit (fatal) %if errors # 0
 5626  
 5627     control = original control
 5628  
 5629  %end
?CVTLW unused
?MOVW unused
?MOVZWL unused
?PSYM unused
?RSYM unused
?BRDIV unused
?BREXP unused
?BEXP unused
?BDIV unused
?BRSH unused
?BSLH unused
 5630  
 5631  %BEGIN
 5632  %END
 5633  
 5634  %end %of %file

 4931 Statements compiled
