Personal tools
You are here: Home Projects SETL LITTLE Source code ASM: Code generation phase, specific to a particular target machine.
Document Actions

ASM: Code generation phase, specific to a particular target machine.

by Paul McJones last modified 2021-03-17 18:32

ASM: Code generation phase, specific to a particular target machine. This version is for the Digital Equipment Corporation DECsystem-10. By Richard Kenner and David Shields, based on the LITTLE code generator for the IBM System/370 by Kenner.

       1 .=member intro
       2 .=list  noauto,nodir
       3 .=title 'dec-10 little code generator.'
       4 .=title 'macros.'
       5 .=list resume,nodir
       6 $     !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
       7 $    the above line contains, in order of ascii codes, the 56
       8 $    characters of the little language, starting in column 7.
       9 /*
      10
      11
      12
      13  $$          $$$$$$$$$$  $$$$$$$$$$  $$$$$$$$$$  $$          $$$$$$$$$$
      14  $$          $$$$$$$$$$  $$$$$$$$$$  $$$$$$$$$$  $$          $$$$$$$$$$
      15  $$              $$          $$          $$      $$          $$
      16  $$              $$          $$          $$      $$          $$
      17  $$              $$          $$          $$      $$          $$$$$$
      18  $$              $$          $$          $$      $$          $$$$$$
      19  $$              $$          $$          $$      $$          $$
      20  $$              $$          $$          $$      $$          $$
      21  $$$$$$$$$$  $$$$$$$$$$      $$          $$      $$$$$$$$$$  $$$$$$$$$$
      22  $$$$$$$$$$  $$$$$$$$$$      $$          $$      $$$$$$$$$$  $$$$$$$$$$
      23
      24
      25
      26
      27   $$$$$$$$    $$$$$$$$   $$      $$   $$$$$$$$       $$         $$$$
      28  $$$$$$$$$$  $$$$$$$$$$  $$$$  $$$$  $$$$$$$$$$    $$$$        $$$$$$
      29  $$      $$  $$       $  $$ $$$$ $$  $$       $    $ $$       $$    $$
      30  $$      $$  $$          $$  $$  $$  $$              $$      $$      $$
      31  $$      $$  $$$$$$$$$   $$  $$  $$  $$$$$$$$$       $$      $$      $$
      32  $$$$$$$$$$   $$$$$$$$$  $$      $$   $$$$$$$$$      $$      $$      $$
      33  $$$$$$$$$$          $$  $$      $$          $$      $$      $$      $$
      34  $$      $$  $       $$  $$      $$  $       $$      $$       $$    $$
      35  $$      $$  $$$$$$$$$$  $$      $$  $$$$$$$$$$  $$$$$$$$$$    $$$$$$
      36  $$      $$   $$$$$$$$   $$      $$   $$$$$$$$   $$$$$$$$$$     $$$$
      37
      38
      39
      40   this software is part of the little programming system.
      41               address queries and comments to
      42
      43                        little project
      44                department of computer science
      45                     new york university
      46          courant institute of mathematical sciences
      47                      251 mercer street
      48                     new york, ny  10012
      49
      50      this program is the code generation (asm) phase for the
      51      digital equipment corporation decsystem-10  (dec-10).
      52      it was written by richard kenner and david shields of
      53      the courant institute, and is based on the little code
      54      generator for the ibm system/370 written by kenner.
      55
      56      dr. anthony p. mccann and nigel chapman of the university
      57      of leeds have agreed to attempt to produce a resident little
      58      compiler for the dec-10 based on this asm.
      59
      60
      61      the program source contains two documentation sections
      62      delimited by conditional symbols doct10 and docnote.
      63      doct10 text contains specification of t10 target language.
      64      docnote contains example little programs and the
      65      generated t10 code; it also contains a preliminary version
      66      of the macro-10 macros to translate t10 to macro-10.
      67      the documentation sections are included here to make this
      68      work more accessible to those interested in studying the
      69      bootstrap t10 compiler.
      70
      71
      72                                                                */
       1 .=member chars
       2 /*   little character set and ascii representation
       3
       4       !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
       5      the above line contains, in order of ascii codes, the 56
       6      characters of the little language, starting in column 7.
       7
       8      the little language requires 56 distinct characters.
       9      these include the 26 upper case letters, the 10 digits,
      10      and the following special characters:
      11
      12        blank
      13      = equal sign, assignment symbol
      14      + plus
      15      - minus
      16      * times, asterisk
      17      / divide, slash
      18      ( left parenthesis
      19      ) right parenthesis
      20      , comma
      21      . period, point
      22      ; semicolon
      23      : colon
      24      $ dollar sign, comment character
      25      ^ not
      26      & and
      27      ! or
      28      < less than
      29      > greater than
      30      ' apostrophe, string delimiter
      31      _ underline, break character
      32
      33      the following table gives the standard ascii encoding
      34      for the little character set.
      35
      36        little character    ascii  ascii  ascii    ascii character
      37                            (hex)  (oct)  (dec)
      38
      39        space                  20     40     32    space
      40      ! or                     21     41     33    exclamation mark
      41      $ dollar sign            24     44     36    dollar sign
      42      & and                    26     46     38    ampersand
      43      ' apostrophe             27     47     39    apostrophe
      44      ( left parenthesis       28     50     40    left parenthesis
      45      ) right parenthesis      29     51     41    right parenthesis
      46      * asterisk               2a     52     42    asterisk
      47      + plus                   2b     53     43    plus
      48      , comma                  2c     54     44    comma
      49      - minus                  2d     55     45    minus
      50      . period                 2e     56     46    period
      51      / slash                  2f     57     47    slant
      52      0 digit 0                30     60     48    digit 0
      53      1 digit 1                31     61     49    digit 1
      54      2 digit 2                32     62     50    digit 2
      55      3 digit 3                33     63     51    digit 3
      56      4 digit 4                34     64     52    digit 4
      57      5 digit 5                35     65     53    digit 5
      58      6 digit 6                36     66     54    digit 6
      59      7 digit 7                37     67     55    digit 7
      60      8 digit 8                38     70     56    digit 8
      61      9 digit 9                39     71     57    digit 9
      62      : colon                  3a     72     58    colon
      63      ; semicolon              3b     73     59    semicolon
      64      < less than              3c     74     60    less than
      65      = equals                 3d     75     61    equals
      66      > greater than           3e     76     62    greater than
      67      a letter a               41    101     65    letter a
      68      b letter b               42    102     66    letter b
      69      c letter c               43    103     67    letter c
      70      d letter d               44    104     68    letter d
      71      e letter e               45    105     69    letter e
      72      f letter f               46    106     70    letter f
      73      g letter g               47    107     71    letter g
      74      h letter h               48    110     72    letter h
      75      i letter i               49    111     73    letter i
      76      j letter j               4a    112     74    letter j
      77      k letter k               4b    113     75    letter k
      78      l letter l               4c    114     76    letter l
      79      m letter m               4d    115     77    letter m
      80      n letter n               4e    116     78    letter n
      81      o letter o               4f    117     79    letter o
      82      p letter p               50    120     80    letter p
      83      q letter q               51    121     81    letter q
      84      r letter r               52    122     82    letter r
      85      s letter s               53    123     83    letter s
      86      t letter t               54    124     84    letter t
      87      u letter u               55    125     85    letter u
      88      v letter v               56    126     86    letter v
      89      w letter w               57    127     87    letter w
      90      x letter x               58    130     88    letter x
      91      y letter y               59    131     89    letter y
      92      z letter z               5a    132     90    letter z
      93      ^ not                    5e    136     94    circumflex
      94      _ underline              5f    137     95    underline
      95
      96
      97      the bootstrap dec-10 asm requires additional characters.
      98      the at and quotation mark appear in the generated code.
      99
     100      @ at                     40    100     64    at
     101      " quotation mark         22     42     34    quotation mark
     102
     103      brackets are used to delimit meta-comments within the program
     104      source.  the meta-comments contain queries, comments and
     105      suggestions about the code; they are to be examined and
     106      dealt with as soon as possible.
     107
     108
     109      [ left bracket           5b    133     91    left bracket
     110      ] right bracket          5d    135     93    right bracket
     111 */
     112
       1 .=member desc
       2 .+doct10.
       3 /*   t 1 0  s p e c i f i c a t i o n s
       4
       5                  t10 language level: 1.0
       6           date of last language change: 07 jun 78
       7      date of last t10 documentation change: 07 jun 78
       8
       9 this section defines the target language t10 of the bootstrap
      10 little code generator for the dec-10.
      11
      12
      13 statement format
      14 ----------------
      15
      16 each line contains either a t10 operation or comment.  a comment
      17 instruction begins with a semicolon in column one, and the
      18 rest of the line contains text.  an operation has an opcode
      19 beginning in column 9 and an operand field beginning in column 17.
      20 the operands may be followed by a comment field, which begins with
      21 a semicolon.
      22
      23 operand formats
      24 ---------------
      25
      26 fnam     an fnam is the name of an external file whose
      27          extension 'unv' contains the macros for translating
      28          t10 operations to valid dec-10 macro-10 assembler
      29          code.  the default for fnam is 't10mac'; other values
      30          can be selected using the 'unv' compiler parameter.
      31
      32 enam     an enam is the external name of a nameset or procedure
      33          truncated to six characters if necessary.
      34
      35 bnam     a bnam is the internal three-character blockname used
      36          to reference the first word of a block of memory.
      37          references to words in the block have the form
      38          'bnam+n' where n is nonnegative integer constant.
      39
      40          bnam's in generated t10 code include the following:
      41
      42          bas  this block contains parameter lists, label lists,
      43               constants and other values generated by bootstrap
      44               code generator.
      45
      46          con  constant block which contains initial values
      47               of program constants.  this block can be placed
      48               in read-only memory if possible (see dbr).
      49
      50          g--  global data areas (namesets) are referenced within
      51               the code by a block name consisting of the letter
      52               g followed by two digits.  numeric codes begin with
      53               10; first nameset is g10, etc.
      54
      55          lcl  this block contains local variables.
      56
      57          tmp  this block contains temporaries.
      58
      59 r        a register name consists of the letter r followed by
      60          a decimal number from zero to 15, and indicates the
      61          corresponding word of memory.  when register addressed
      62          as memory, an attempt is made to use reg and not
      63          just memory location value, i.e., 'r3' instead of '3'.
      64
      65 n        indicates a nonnegative integer constant with size
      66          at most 18 bits
      67
      68 acon     address constant for dwa operation, has the form
      69          bnam+n.
      70
      71 ccon     character code constant for dwc operation, in the
      72          form of a sixbit character string delimited by
      73          apostrophes.  apostrophes within the string are
      74          doubled.  the string is to be assembled right-
      75          justified with zero fill on the left.
      76
      77 icon     signed integer constant for dwi operation.
      78
      79 ocon     octal constant for dwo operation.
      80
      81 rcon     floating point constant for dwr operation.  in same
      82          form as in little source, except that internal blanks
      83          are eliminated.
      84
      85 scon     character string constant for dws operation.  in
      86          the form of a sixbit character string delimited by
      87          quotation marks.  quotation marks within the string
      88          are doubled.  the string is to be assembled left-
      89          justified with blank fill.
      90
      91 plbl     a program label consists of the letter l followed
      92          by three decimal digits.  a lab instruction indicates
      93          the definition point of a plbl.  plbl's may occur only
      94          in branching operations.
      95
      96 ea       an effective address which specifies the memory location
      97          of an operand.  the ea consists of four parts, as follows:
      98
      99          indirection     indicated by letter at (@)
     100          block name      a bnam
     101          block offset    signed integer constant
     102          index register  register name enclosed in parentheses
     103
     104          all parts are optional, but specified parts must be given
     105          in the order above.  if no parts given, value of zero
     106          is implied, although bootstrap asm will never produce
     107          such a null ea.
     108
     109          the bnam is optional, but if it is given then the
     110          offset must be nonnegative.  if the offset is not given, an
     111          offset of zero is implied, although bootstrap asm will
     112          never produce such an ea.
     113
     114          the address is formed by first taking block name and
     115          offset to determine address.  if nonzero index
     116          register specified, then contents of the index register
     117          are added to address.  the resulting value is the location
     118          of the word containing the operand, unless indirection
     119          is specified, in which case the word addressed contains
     120          the location of the operand.
     121
     122 eai      an eai is similar to an ea except that it admits the
     123          possibility of specifying a short (up to 18 bit) value
     124          using the ea field directly, without requiring a memory
     125          access.  the operand value is that of the ea itself, and
     126          not the word addressed by ea.  an instance of such an
     127          operand, called 'immediate', is denoted by appending
     128          i to the t10 opcode.
     129
     130          note that certain instructions have four letter opcodes
     131          ending in i.  such instructions have ea which is always
     132          immediate value.
     133
     134 the following table lists the t10 opcodes in alphabetical order.
     135 there follows a description of the opcodes according to their
     136 function.
     137
     138
     139  3.1   ban     r,eai           set (r) to (r) .and. (eai)
     140  3.4   bfb     r,ea            set (r) to .fb. (ea)
     141  3.5   bnb     r,ea            set (r) to .nb. (ea)
     142  3.6   bno     r,ea            set (r) to .not.(ea)
     143  3.2   bor     r,eai           set (r) to (r) .or. (eai)
     144  3.3   bxo     r,eai           set (r) to (r) .exor. (eai)
     145  7.3   cal     enam,n1,bnam+n2 call procedure enam, n1 args at bnam+n2
     146  6.2   ceq     r,eai           skip next instruction if (r) eq (eai)
     147  6.5   cge     r,eai           skip next instruction if (r) ge (eai)
     148  6.4   cgt     r,eai           skip next instruction if (r) gt (eai)
     149  6.7   cle     r,eai           skip next instruction if (r) le (eai)
     150  6.6   clt     r,eai           skip next instruction if (r) lt (eai)
     151  6.3   cne     r,eai           skip next instruction if (r) ne (eai)
     152  1.8   dbr     bnam,n          define read-only block bnam of n words
     153  1.9   dbw     bnam,n          define writeable block bnam of n words
     154  1.5   dec     enam            define end of code for procedure enam
     155  1.3   dep     enam            define end of procedure enam
     156  1.6   dna     enam,bnam,n     define access of nameset enam
     157  1.7   dnd     enam,bnam,n     define nameset enam
     158  1.4   dsc     enam            define start of code for procedure enam
     159  1.2   dsp     enam,n1,n2      define start of procedure enam
     160  1.10  dwa     bnam+n,acon     define word with address
     161  1.11  dwc     bnam+n,ccon     define word with character code
     162  1.12  dwi     bnam+n,icon     define word with integer
     163  1.13  dwo     bnam+n,ocon     define word with octal
     164  1.14  dwr     bnam+n,rcon     define word with real
     165  1.15  dws     bnam+n,scon     define word with character string
     166  1.16  dwz     bnam+n1,n2      define initial block of zeros
     167  7.1   ent     enam            enter procedure enam
     168  4.7   iab     r,ea            set (r) to iabs((ea))
     169  4.1   iad     r,eai           integer add (eai) to (r)
     170  4.9   iao     r,ea            integer add one: set (r) to (ea)+1
     171  4.8   ico     r,ea            integer complement of (ea) to (r)
     172  4.4   idi     r,eai           integer divide (r) by (eai)
     173  4.12  idti    r,n             divide (r) by n-th power of two
     174  4.13  ieq     r,eai           set (r) to 1 if (r) eq (eai), else 0
dsj    1  4.19  ifr     r,ea            set (r) to ifix((ea))
     175  4.16  ige     r,eai           set (r) to 1 if (r) ge (eai), else 0
     176  4.15  igt     r,eai           set (r) to 1 if (r) gt (eai), else 0
     177  4.18  ile     r,eai           set (r) to 1 if (r) le (eai), else 0
     178  4.17  ilt     r,eai           set (r) to 1 if (r) lt (eai), else 0
     179  4.5   imo     r,eai           set (r) to mod((r),(eai))
     180  4.11  imti    r,n             multiply (r) by n-th power of two
     181  4.3   imu     r,eai           integer multiply (eai) by (r)
     182  4.14  ine     r,eai           set (r) to 1 if (r) ne (eai), else 0
     183  4.6   isi     r,eai           set (r) to isign((r),(eai))
     184  4.10  iso     r,ea            integer subtract one: set (r) to (ea)-1
     185  4.2   isu     r,eai           integer subtract (eai) from (r)
     186  6.8   jeq     r,plbl          jump to plbl if (r) eq 0
     187  6.11  jge     r,plbl          jump to plbl if (r) ge 0
     188  6.10  jgt     r,plbl          jump to plbl if (r) gt 0
     189  6.13  jle     r,plbl          jump to plbl if (r) le 0
     190  6.12  jlt     r,plbl          jump to plbl if (r) lt 0
     191  6.15  jmn     r,plbl          jump never to plbl
     192  6.14  jmp     r,plbl          jump always to plbl
     193  6.9   jne     r,plbl          jump to plbl if (r) ne 0
     194  6.1   lab     plbl            define label plbl
     195  2.2   lda     r,ea            set (r) to ea
     196  2.6   ldf     r,ea            load (r) from byte pointer in (ea)
     197  2.8   ldl     r,ea            set (r) to .f. 19,18,(ea)
     198  2.9   ldr     r,ea            set (r) to .f. 1,18,(ea)
     199  2.1   ldw     r,eai           set (r) to (eai)
eaa    1 .+t20.
eaa    2  3.14  lla     r,ea            set (r) to rh(ea) - for local address
eaa    3                                (extended addressing only)
eaa    4 ..t20
     200  2.4   lpr     r,ea,n1,n2      set (r) to .f. n1+1,n2,(ea)
dsa    1  2.12  mvw     r,ea,n          move n words from ea to (r)
dsu    1  2.12  mvx     r,ea,n          move n words from (r) to ea
     202  5.7   rab     r,ea            set (r) to abs((ea))
     203  5.1   rad     r,eai           real add (eai) to (r)
     204  5.8   rco     r,eai           real complement of (eai) to (r)
     205  5.4   rdi     r,eai           real divide (r) by (eai)
     206  5.9   req     r,eai           set (r) to 1 if (r)-(eai) eq 0.0, else 0
     207  7.2   ret     enam            return from procedure enam
dsj    2  5.15  rfi     r,eai           set (r) to float((eai))
     208  5.12  rge     r,eai           set (r) to 1 if (r)-(eai) ge 0.0, else 0
     209  5.11  rgt     r,eai           set (r) to 1 if (r)-(eai) gt 0.0, else 0
     210  5.14  rle     r,eai           set (r) to 1 if (r)-(eai) le 0.0, else 0
     211  5.13  rlt     r,eai           set (r) to 1 if (r)-(eai) lt 0.0, else 0
     212  5.5   rmo     r,eai           set (r) to amod((r),(eai))
     213  5.3   rmu     r,eai           real multiply (r) by (eai)
     214  5.10  rne     r,eai           set (r) to 1 if (r)-(eai) ne 0.0, else 0
     215  5.6   rsi     r,eai           set (r) to sign((r),(eai))
     216  5.2   rsu     r,eai           real subtract (eai) from (r)
dsj    3  5.16  rtr     r,ea            set (r) to aint((ea))
     217  1.1   search  fnam            specify universal file for search
     218  2.5   spr     r,ea,n1,n2      set .f. n1+1,n2,(ea) to .f. 1,n2,(r)
     219  2.7   stf     r,ea            store (r) to byte pointer in (ea)
     220  2.10  stl     r,ea            set .f.19,18,(ea) to .f. 1,18,(r)
     221  2.11  str     r,ea            set .f.1,18,(ea) to .f. 1,18,(r)
     222  2.3   stw     r,ea            set (ea) to (r)
     223  2.14  zebi    r,n             zeroize n words starting at (r)
     224  2.13  zew     r,ea            set (ea) to zero
     225
     226
     227 description of t10 operations
     228 -----------------------------
     229
     230 -1-    declaration and definition operations
     231
     232        these operations define the structure of a program and specify
     233        the initial value of memory locations.
     234        they are not executable.
     235
     236  1.1   search  fnam            specify universal file for search
     237
     238        the search operation specifies the file to be searched
     239        for macro definitions to translate the t10 code into valid
     240        dec-10 macro-10 instructions.  if present, the search
     241        instruction is the first t10 instruction in a procedure.
     242
     243  1.2   dsp     enam,n1,n2      define start of procedure enam
     244  1.3   dep     enam            define end of procedure enam
     245
     246        the dsp and dep instructions begin and end a procedure
     247        definition, respectively.  dsp and dep are required.  dsp
     248        is the first instruction in a procedure, unless a search
     249        instruction is present, in which case the dsp immediately
     250        follows the search instruction.  the dep instruction is
     251        the last instruction in a procedure.
     252
     253        the first argument of both dsp and dep is the external
     254        name of the procedure.  the second argument of a dsp gives
     255        the number of arguments; the third argument gives the type
     256        of the procedure, as follows:
     257
     258        0       subroutine (subr)
     259        1       function (fnct)
     260        2       program (prog)
     261
     262  1.4   dsc     enam            define start of code for procedure enam
     263  1.5   dec     enam            define end of code for procedure enam
     264
     265        the dsc instruction indicates the start of the executable code
     266        section for a procedure, the dec instruction indicates the end
     267        of the code section.  both are required, and all executable
     268        instructions must occur in the code section.  for the dec-10,
     269        the dsc effects relocation to high segment, the dec returns
     270        relocation to low segment.
     271
     272  1.6   dna     enam,bnam,n     define access of nameset enam
     273  1.7   dnd     enam,bnam,n     define nameset enam
     274
     275        the dna and dnd instructions effect access and definition of
     276        global data areas.  enam is the external name of the block,
     277        bnam is the internal name of the block used in t10 instructions,
     278        and n is the length of the block in words.  the dnd instruction
     279        specifies that this procedure define the data area, and so may
     280        contain data definition (dw-) instructions for words in the
     281        data area.
     282
     283  1.8   dbr     bnam,n          define read-only block bnam of n words
     284  1.9   dbw     bnam,n          define writeable block bnam of n words
     285
     286        the dbr and dbw instructions reserve blocks of working storage.
     287        the words in a dbr block are never written, so that a dbr block
     288        should be allocated in read-only memory if this is possible.
     289
     290  1.10  dwa     bnam+n,acon     define word with address
     291  1.11  dwc     bnam+n,ccon     define word with character code
     292  1.12  dwi     bnam+n,icon     define word with integer
     293  1.13  dwo     bnam+n,ocon     define word with octal
     294  1.14  dwr     bnam+n,rcon     define word with real
     295  1.15  dws     bnam+n,scon     define word with character string
     296
     297        the dw operations define the initial value of a memory word.
     298        the first operand specfies the location of the word to be
     299        initialized and has the form bnam+n where bnam is a block
     300        defined by dbr, dbw or dnd instruction, and n is the offset
     301        within the block.  the second operand specifies the value to
     302        which the word is to be initialized, according to the
     303        operation code.
     304
     305  1.16  dwz     bnam+n1,n2      define initial block of zeros
     306
     307        a dwz instruction indicates that the n2 words beginning at
     308        location bnam+n1 are to be initialized to zero.
     309
     310 -2-    data transmission instructions
     311
     312        these instructions transmit data without operating upon it, and
     313        are used to move parts of words, single words
     314        and blocks of words.
     315
     316  2.1   ldw     r,eai           set (r) to (eai)
     317  2.2   lda     r,ea            set (r) to ea
eaa    5 .+t20.
eaa    6  3.14  lla     r,ea            set (r) to rh(ea)  (extended addressing)
eaa    7 ..t20
     318  2.3   stw     r,ea            set (ea) to (r)
     319
     320        the ldw instruction moves the operand value to a register.
     321        the lda instruction moves the operand location to a register,
     322        and is equivalent to ldwi.
eaa    8 .+t20.
eaa    9        for extended addressing, this is an xmovei.
eaa   10        the lla instruction moves the right half of the operand
eaa   11        location to a register, and should be used whenever this will
eaa   12        be used in a local context.  it is equivalent to ldri.
eaa   13 ..t20
     323        the stw instruction stores the register contents at the
     324        operand location.
     325
     326  2.4   lpr     r,ea,n1,n2      set (r) to .f. n1+1,n2,(ea)
     327  2.5   spr     r,ea,n1,n2      set .f. n1+1,n2,(ea) to .f. 1,n2,(r)
     328
     329        the lpr and spr instructions operate on part of a word.  the
     330        constants n1 and n2 specify the starting point of the field and
     331        the length of the field in bits, respectively.  n1 is the little
     332        field origin minus one.  n2 is the field size.
     333
     334  2.6   ldf     r,ea            load (r) from byte pointer in (ea)
     335  2.7   stf     r,ea            store (r) to byte pointer in (ea)
     336
     337        the ldf and stf instructions operate on part of a word, using a
     338        byte pointer explicitly constructed using lpr and spr
     339        operations.
     340        such a byte pointer is always constructed in a register, and the
     341        ea of the ldf and stf will usually, although not necessarily, be
     342        a register.
     343        the generated byte pointer has same format and interpretation
     344        as a dec-10 byte pointer:
     345
     346        .f. 01, 24, - ea of word containing byte
     347        .f. 25, 06, - byte length in bits
     348        .f. 31, 06, - number of bits to right of rightmost bit in byte.
     349
     350  2.8   ldl     r,ea            set (r) to .f. 19,18,(ea)
     351  2.9   ldr     r,ea            set (r) to .f. 1,18,(ea)
     352  2.10  stl     r,ea            set .f.19,18,(ea) to .f. 1,18,(r)
     353  2.11  str     r,ea            set .f.1,18,(ea) to .f. 1,18,(r)
     354
     355
     356        the halfword ops transmit halfword values using the dec-10
     357        halfword operations.  they can be considered to be defined
     358        by lpr and spr operations, as follows:
     359
     360        ldl r,ea   <->  lpr r,ea,18,18
     361        ldr r,ea   <->  lpr r,ea,0,18
     362        stl r,ea   <->  spr r,ea,18,18
     363        str r,ea   <->  spr,r,ea,0,18
     364
dsa    2  2.12  mvw     r,ea,n          move n words from ea to (r)
     366
dsa    3        the mvw instruction moves a block of memory. ea specifies
dsa    4        the address of the first word to be moved, (r) contains the
     369        address of the first word to which data is to be moved, and
     370        n specifies the number of words to be moved.
dsu    2
dsu    3        mvx is like mvw, but moves from (r) to ea.
     371
     372  2.13  zew     r,ea            set (ea) to zero
     373  2.14  zebi    r,n             zeroize n words starting at (r)
     374
     375        the zew instruction clears a memory location.  the zebi
     376        instruction clears the n words beginning at the
     377        specified memory location.
     378
     379
     380
     381 -3-    the boolean operations operate on full word values.
     382
     383  3.1   ban     r,eai           set (r) to (r) .and. (eai)
     384  3.2   bor     r,eai           set (r) to (r) .or. (eai)
     385  3.3   bxo     r,eai           set (r) to (r) .exor. (eai)
     386
     387        the binary operations combine the operand value and the register
     388        contents, and store the result in the register.
     389
     390  3.4   bfb     r,ea            set (r) to .fb. (ea)
     391  3.5   bnb     r,ea            set (r) to .nb. (ea)
     392  3.6   bno     r,ea            set (r) to .not.(ea)
     393
     394        the bno instruction inverts a full word, so that correct
     395        translation of the little not is effected by using lpr to
     396        extract desired part of full-word value computed by bno.
     397
     398 -4-    integer arithmetic operations
     399
     400  4.1   iad     r,eai           integer add (eai) to (r)
     401  4.2   isu     r,eai           integer subtract (eai) from (r)
     402  4.3   imu     r,eai           integer multiply (eai) by (r)
     403  4.4   idi     r,eai           integer divide (r) by (eai)
     404  4.5   imo     r,eai           set (r) to mod((r),(eai))
     405  4.6   isi     r,eai           set (r) to isign((r),(eai))
     406
     407        the binary operations combine the operand value and the register
     408        contents, and store the result in the register.
     409
     410  4.7   iab     r,ea            set (r) to iabs((ea))
     411  4.8   ico     r,ea            integer complement of (ea) to (r)
dsj    4  4.19  ifr     r,ea            set (r) to ifix((ea))
     412
     413        the integer complement is the result of subtracting the operand
     414        value from zero.
     415
     416  4.9   iao     r,ea            integer add one: set (r) to (ea)+1
     417  4.10  iso     r,ea            integer subtract one: set (r) to (ea)-1
     418
     419        the operations iao and iso effect integer addition and
     420        subtraction of the value one, respectively.
     421
     422  4.11  imti    r,n             multiply (r) by n-th power of two
     423  4.12  idti    r,n             divide (r) by n-th power of two
     424
     425        the imti and idti instructions are special cases of the imu and
     426        idi instructions where the divisor is a power of two.  such
     427        operations can be effected by appropriate arithmetic shift.
     428        to avoid incorrect results for division of a negative number,
     429        the idti instruction is never emitted if the dividend
     430        has size ws.
     431
     432  4.13  ieq     r,eai           set (r) to 1 if (r) eq (eai), else 0
     433  4.14  ine     r,eai           set (r) to 1 if (r) ne (eai), else 0
     434  4.15  igt     r,eai           set (r) to 1 if (r) gt (eai), else 0
     435  4.16  ige     r,eai           set (r) to 1 if (r) ge (eai), else 0
     436  4.17  ilt     r,eai           set (r) to 1 if (r) lt (eai), else 0
     437  4.18  ile     r,eai           set (r) to 1 if (r) le (eai), else 0
     438
     439        the integer comparison operations compare the register contents
     440        and the operand value, setting the register to one if the
     441        relation is true, or to zero if it is not.
     442
     443 -5-    real (floating point) operations
     444
     445  5.1   rad     r,eai           real add (eai) to (r)
     446  5.2   rsu     r,eai           real subtract (eai) from (r)
     447  5.3   rmu     r,eai           real multiply (r) by (eai)
     448  5.4   rdi     r,eai           real divide (r) by (eai)
     449  5.5   rmo     r,eai           set (r) to amod((r),(eai))
     450  5.6   rsi     r,eai           set (r) to sign((r),(eai))
     451
     452        the binary operations combine the operand value and the register
     453        contents, and store the result in the register.
     454        the memory operand may be immediate mode, although this should
     455        not occur.  the eai case results from the method in which these
     456        operations are processed by the bootstrap asm.
     457
     458  5.7   rab     r,ea            set (r) to abs((ea))
     459  5.8   rco     r,eai           real complement of (eai) to (r)
dsj    5  5.15  rfi     r,eai           set (r) to float((eai))
dsj    6  5.16  rtr     r,ea            set (r) to aint((ea))
     460
     461  5.9   req     r,eai           set (r) to 1 if (r)-(eai) eq 0.0, else 0
     462  5.10  rne     r,eai           set (r) to 1 if (r)-(eai) ne 0.0, else 0
     463  5.11  rgt     r,eai           set (r) to 1 if (r)-(eai) gt 0.0, else 0
     464  5.12  rge     r,eai           set (r) to 1 if (r)-(eai) ge 0.0, else 0
     465  5.13  rlt     r,eai           set (r) to 1 if (r)-(eai) lt 0.0, else 0
     466  5.14  rle     r,eai           set (r) to 1 if (r)-(eai) le 0.0, else 0
     467
     468        the real comparison operations compare the register contents
     469        and the operand value, setting the register to (integer) one if
     470        the relation is true, or to (integer) zero if it is not.
     471
     472
     473 -6-    branching instructions
     474
     475        the branching instructions control program execution.  a
     476        program label is always defined in the code section by a
     477        lab instruction.
     478
     479  6.1   lab     plbl            define label plbl
     480
     481  6.2   ceq     r,eai           skip next instruction if (r) eq (eai)
     482  6.3   cne     r,eai           skip next instruction if (r) ne (eai)
     483  6.4   cgt     r,eai           skip next instruction if (r) gt (eai)
     484  6.5   cge     r,eai           skip next instruction if (r) ge (eai)
     485  6.6   clt     r,eai           skip next instruction if (r) lt (eai)
     486  6.7   cle     r,eai           skip next instruction if (r) le (eai)
     487
     488        the branch comparison instructions compare the register contents
     489        and the operand value, and cause the next instruction to be
     490        skipped if the relation is true.
     491        these instructions do not alter the register contents.
     492
     493  6.8   jeq     r,plbl          jump to plbl if (r) eq 0
     494  6.9   jne     r,plbl          jump to plbl if (r) ne 0
     495  6.10  jgt     r,plbl          jump to plbl if (r) gt 0
     496  6.11  jge     r,plbl          jump to plbl if (r) ge 0
     497  6.12  jlt     r,plbl          jump to plbl if (r) lt 0
     498  6.13  jle     r,plbl          jump to plbl if (r) le 0
     499  6.14  jmp     r,plbl          jump always to plbl
     500  6.15  jmn     r,plbl          jump never to plbl
     501
     502        the jump operations compare the register contents with zero
     503        and cause a branch to the plbl if the relation is true.
     504        the jmp instruction always causes a jump.  the jmn instruction
     505        never causes a jump, and is thus a no-op.  the jmp and jmn
     506        instructions always specify a register, usually r0, although the
     507        contents of the register do not determine if the branch is
     508        or is not taken.
     509        these instructions do not alter the register contents.
     510
     511 -7-    procedure linkage
     512
     513        ent is the first instruction executed on procedure invocation,
     514        cal is used to invoke other procedures and ret is used to return
     515        from a procedure invocation.
     516
     517        the bootstrap asm makes specific assumptions about register
     518        usage but otherwise permits some freedom in implementation
     519        of linkage.
     520
     521        the bootstrap asm allocates registers r0 through r11.  r0 is
     522        used to return the result of a function invocation.  within a
     523        procedure that has arguments r11 is used to address the
     524        paramater list.  a parameter list is a list of words containing
     525        the addresses of the corresponding procedure arguments.
     526        the bootstrap asm allocates parameter lists within
     527        the base block (bnam 'bas').
     528
     529        the bootstrap asm requires that register contents be preserved
     530        over a cal instruction.  this requires that the called procedure
     531        save the registers before beginning execution and restore them
     532        before returning.
     533
     534  7.1   ent     enam            enter procedure enam
     535
     536        the ent is the first instruction executed in a procedure and
     537        must occur within the code section.  it immediately follows the
     538        dsc instruction.  the required register save action depends on
     539        procedure type (which is given by third argument of dsp
     540        instruction) as follows:
     541        follows
     542
     543        0 (subr)        registers r0 through r11 must be saved
     544        1 (fnct)        registers r1 through r11 must be saved.  r0 need
     545                        not be saved, as it will be set to contain
     546                        function value
     547        2 (prog)        registers need not be saved, as a program never
     548                        returns to caller.
     549
     550        if the procedure has arguments, indicated by the second argument
     551        of the dsp instruction having a value greater than zero, then
     552        the third argument of the cal instruction contains the address
     553        of the parameter list.  after saving the registers, this
     554        address is to be copied to r11.
     555
     556        on entry, the procedure can compare the number of arguments
     557        given in the dsp instruction with the number actually supplied,
     558        as indicated by the second argument of the cal instruction which
     559        invoked the procedure.
     560
     561  7.2   ret     enam            return from procedure enam
     562
     563        a return instruction restores the registers and returns to
     564        point of invocation.  register restore done as follows,
     565        according to procedure type indicated by third argument of
     566        dsp instruction.
     567
     568        0 (subr)        restore registers r0 through r11
     569        1 (fnct)        restore registers r1 through r11
     570        2 (prog)        a return within a prog is invalid and should be
     571                        treated as an error.  the compiler should map
     572                        return's in a prog into calls to the standard
     573                        library termination routine ltlfin.
     574
     575  7.3   cal     enam,n1,bnam+n2 call procedure enam, n1 args at bnam+n2
     576
     577        a cal instruction calls the named procedure.  the second
     578        argument gives the number of arguments.  if it is zero,
     579        indicating no arguments, the third argument of cal will be zero.
     580        otherwise third argument of cal instruction will be address in
     581        address in base block (bnam 'bas') of the start of the
     582        parameter list.
     583
     584
     585
     586 */
     587 ..doct10
       1 .=member mods
       2 $    ---all corrections are to insert self-description after mods.2---
pic    1
pic    2 $    pic       d. shields          01-sep-82           level 82244
pic    3 $              r. kenner
pic    4 $
pic    5 $   1. fix bug in asmlong re comparison of multi-word items.
pic    6 $   2. generate position independent code for vax vms.
pic    7 $
dsw    1
dsw    2 $    dsw       d. shields          15-jan-82           level 82015
dsw    3 $
dsw    4 $    avoid generating 'g--' symbols for s32u, as they are too much for
dsw    5 $    'as' to deal with; generate full global block name instead.
dsw    6 $    decks affected - eminit, outdata, outcon.
dsw    7
dsv    1
dsv    2 $    dsv       d. shields          20-nov-81           level 81324
dsv    3 $
dsv    4 $    1.  support t32h for unix (s32) also.
dsv    5 $    2.  for s32 nsheap, address the first word in nsheap (heap_addr)
dsv    6 $        directly, except within parameter lists.
dsv    7 $    decks affected - emitea, macros
dsv    8
dsu    4
dsu    5 $    dsu       d. shields          02-oct-81           level 81278
dsu    6 $
dsu    7 $    1.  generate opcode mvx where needed. mwx is like mvw, except
dsu    8 $        operands in other order.
dsu    9 $        this affects all implementations.
dsu   10 $    2.  for s32, support program option 'nsheap=/nsheap', so that if
dsu   11 $        a nameset given, then that specified nameset will be addressed
dsu   12 $        indirectly. this permits dynamic allocation
dsu   13 $        of the setl heap, for example. the generated code asssumes the
dsu   14 $        first word in the nameset contains the dynamic address. this
dsu   15 $        value is loaded at the start of each procedure referencing the
dsu   16 $        nameset; thereafter, references are made using the dynamic
dsu   17 $        address which is kept in a register, together with the vax
dsu   18 $        'indexed' addressing mode of the form '[r..]'.
dsu   19 $        code is conditioned by symbol t32h, and is currently enabled
dsu   20 $        for s32v (vax vms). new t32 ops include the following
dsu   21 $          lha rb,rw,loc    load loc to rb
dsu   22 $            rb is register to get byte address, rw to get word address
dsu   23 $          sha var,ea       store heap address of var in ea
dsu   24 $    decks affected - macros, start, asmini, setup, eminit, emitsub
dsu   25 $        storer, endsubr, emopr, emitea, emiteh (new)
dsu   26
eaa   14
eaa   15 $    eaa       c. hedrick          29-aug-81           level 81243
eaa   16 $              d. shields
eaa   17 $
eaa   18 $    add support for t20, extended addressing extension of t10.
eaa   19 $    adds two parameters
eaa   20 $        nsheap=/nsheap  name of nameset to be 'relocated'
eaa   21 $        nshorg=^o2000001/      extended address of nsheap nameset.
eaa   22 $                              (section two)
eaa   23 $    if nsheap selected, all references to variables in the specified
eaa   24 $    nameset are done indirectly with efiw macro.
eaa   25 $    this nameset must contain only single-word variables and
eaa   26 $    variables in it cannot be initialized with data statements.
eaa   27 $    the new (t20) opcodes are hba, hbb, hbc, lla, and dha.
eaa   28 $    build this asm by compiling with 'iset=t20'.
eaa   29 $    decks affected - macros, start, asmini, eminit, asmfld, getword,
eaa   30 $        endsubr, emitea, emitex (new)
eaa   31
dst    1
dst    2 $    dst       d. shields          17-jun-81           level 81168
dst    3 $
dst    4 $    1.  add option nspage=0/1 such that nspage=1 causes pnd and pna
dst    5 $        ops to be emitted instead of dnd and dna, respectively. this
dst    6 $        is principally for variant setl lib on vax where want in some
dst    7 $        cases to align namesets on page boundaries.
dst    8 $    2.  add measurement feature 'enp' consisting of two new
dst    9 $        options, enp=0/t.rep and enporg=0/0. if enp specified, the
dst   10 $        specified file must have been created using rep=p gen option
dst   11 $        the generated code will contain (new) opcode 'enp' with
dst   12 $        argument determined by the position of the procedure in the
dst   13 $        enp file,
dst   14 $        incremented by value of enporg parameter. this makes it
dst   15 $        possible at run-time to determine the active procedure.
dst   16 $        enp instructions are emitted at start of each procedure and
dst   17 $        after each call instruction within the generated code.
dst   18 $        this feature conditioned by symbol 'enp', which is set for s32
dst   19 $    decks affected - start, asmini, eminit, endsubr, eminit, asmexit.
dst   20
rke    1
rke    2 $    rke       r. kenner           12-nov-80           level 80317
rke    3 $              d. shields
rke    4 $
rke    5 $    1.  fix problem (fr156) in handling of multi-word temporaries.
rke    6 $    2.  avoid sending abnormal termination dumps to terminal.
rke    7 $    decks affected - assign, aermey.
rke    8
rkd    1
rkd    2 $    rkd       r. kenner           02-sep-80           level 80246
rkd    3 $
rkd    4 $    fix bug (fr150) that caused stores of live quantities to not be
rkd    5 $    done when same variable used in arithmetic operation where another
rkd    6 $    variable is both output and input, and where the live variable is
rkd    7 $    second argument. for example, in 'i=i+j', j was not stored.
rkd    8 $    deck affected - emitdop.
rkd    9
dss    1
dss    2 $    dss       d. shields          08-aug-80           level 80217
dss    3 $
dss    4 $    modify t32u to cater to unix assembler (as) as follows:
dss    5 $    1.  generate unique names for local blocks (base, label, const,
dss    6 $        temp) by generating new name for each procedure. for example,
dss    7 $        base block identified as baa in first procedure, bab in second
dss    8 $        and so forth. the second and third characters of these names
dss    9 $        are generated in upper case.
dss   10 $    2.  also make label names unique, use five digit label.
dss   11 $    decks affected - setup, eminit, branchr, labdef, endsubr.
dss   12
dsr    1
dsr    2 $    dsr       d. shields          30-jul-80           level 80212
dsr    3 $
dsr    4 $    1.  fix problem in listing ats option value.
dsr    5 $    2.  fix problem in representation of grave accent for t32u, as
dsr    6 $        this character not in s66 character set.
dsr    7 $    decks affected - macros, asmini, emitea.
dsr    8
dsq    1
dsq    2 $    dsq       d. shields          21-jul-80           level 80203
dsq    3 $
dsq    4 $    1.  for t32, add option iv=0/1 such that iv=1 causes
dsq    5 $        integer overflow bit to be set in procedure entry
dsq    6 $        mask of all procedures compiled, so that integer
dsq    7 $        overflows can be trapped.
dsq    8 $    2.  if hmeqtm, generate tabs in generated code. this not
dsq    9 $        fully machine-independent, but all current machines
dsq   10 $        s10, s32 (both vms and unix) are dec and use same tab
dsq   11 $        conventions. this reduces size of generated code files,
dsq   12 $        by at least a third for most programs based on initial
dsq   13 $        test.
dsq   14 $    3.  delete 'no errors detected message'.
dsq   15 $    4.  add program parameter ats=1/0 such that ats=1 causes
dsq   16 $        generated code to include date of compilation.  ats=0 meant
dsq   17 $        for use during replication to compare generated code files.
dsq   18 $    5.  begin work on bootstrapping to s32 unix. this requires
dsq   19 $        possibility of producing two t32 variants:
dsq   20 $        t32v - vms
dsq   21 $        t32u - unix.
dsq   22 $        nyu currently using vms, hence iset=unix required to
dsq   23 $        configure for unix.  note that unix assembler (as)
dsq   24 $        does not support macros, so that a separate c processor
dsq   25 $        is required. hence, changes for t32u are initially as
dsq   26 $        small as possibile, and mainly reflect different unix
dsq   27 $        conventions for specifying indirection and literals.
dsq   28 $        no provision has been made for differing default file
dsq   29 $        names, etc.; this distinction can be introduced by
dsq   30 $        adding s32u/s32v conditional symbols later.
dsq   31 $
dsq   32 $        decks affected - macros, start, asmini, eminit,
dsq   33 $            endsubr, emitea, emopr, ocsput.
dsq   34
dsp    1
dsp    2 $    dsp       d. shields          26-feb-80           level 80057
dsp    3 $
dsp    4 $    fix errors reported by chuck hedrick at rutgers relating
dsp    5 $    to s10/t10.
dsp    6 $    1.  missing comment character after mcs definition
dsp    7 $    2.  missing semicolon.
dsp    8 $    also fix error (fr2.3.131) in labfix that caused errors
dsp    9 $    in compiling some until loops.
dsp   10 $    also add new t10 option 'end=prg/seg' such if value other
dsp   11 $    than '0' specified, code file ended as follows
dsp   12 $    1.  end=prg places
dsp   13 $            extern z$strt
dsp   14 $            end    z$strt
dsp   15 $        at end of code file.
dsp   16 $    2.  end=seg places
dsp   17 $            end
dsp   18 $        at end of code file.
dsp   19 $    3.  end=nam, where nam not prg or seg, places
dsp   20 $            endnam
dsp   21 $        at end of code file.
dsp   22 $    decks affected - macros, start, asmini, sdsnam, sdlnam,
dsp   23 $        labfix, asmexit.
dsp   24
dso    1
dso    2 $    dso       d. shields          04-feb-80           level 80035
dso    3 $
dso    4 $    1.  increase ha dimension to 937.
dso    5 $    2.  fix error that caused looping in some cases
dso    6 $        while printing tables on abnormal termination.
dso    7 $    decks affected - macros, aermey
dso    8
dsn    1
dsn    2 $    dsn       d. shields          14-dec-79           level 79348
dsn    3 $
dsn    4 $    1.  rewind voa file only for s66.
dsn    5 $    2.  support long filenames for s32.
dsn    6 $    3.  list actual parameter string.
dsn    7 $    4.  extend maximum permitted dimension for s10, s32 and s37 up
dsn    8 $        to 2**n-1 with n=17, 30 and 22, respectively. this involves
dsn    9 $        change to voa, nl, mba and xha, so that voa file format change
dsn   10 $    remaining changes apply to s10 version.
dsn   11 $    5.  change extent for code file from .t10 to .mac.
dsn   12 $    6.  correct miscellaneous bugs found in porting to
dsn   13 $        rutgers.
dsn   14 $    7.  change _ to $ in external names.
dsn   15 $    8.  change code file extent from .t10 to .mac for t10.
dsn   16 $    decks affected - macros, start, asmini, sdlnam, sdsnam, outcon.
dsn   17
vaxa   1
vaxa   2 $    vaxa      r. kenner           11-sep-79           level 79254
vaxa   3 $
vaxa   4 $    extend to support generation of code for dec vax-11/780 (s32).
vaxa   5 $    source configured according to conditional assembly options.
vaxa   6 $    t10  -  set to produce t10 code for s10.
vaxa   7 $    t32  -  set to produce t32 code for s32.
vaxa   8 $    hmeqtm - set if host and target machine are the same.
vaxa   9 $    decks affected - most.
vaxa  10
rkc    1
rkc    2 $    rkc       r. kenner           10-sep-79           level 79253
rkc    3 $
rkc    4 $    fix bug (fr2.3.122) that caused miscompilation of some expressions
rkc    5 $    involving .seq. and .sne. operators.
rkc    6 $    deck affected - emitdop.
rkc    7
rkb    1
rkb    2 $    rkb       r. kenner           18-may-79           level 79138
rkb    3 $
rkb    4 $    fix bug (fr2.3.108) that was due to constants of size larger
rkb    5 $    than cval field in ditems being considered short. resolve this
rkb    6 $    by adding new parameter -scs- corresponding to size of cval field.
rkb    7 $    also do not consider arguments to be eligible for permanent
rkb    8 $    register allocation (this fixes fr2.3.109).
rkb    9
rkb   10 $    decks affected - setup, assign.
rkb   11
dsm    1
dsm    2 $    dsm       d. shields          29 mar 79           level 79088
dsm    3 $
dsm    4 $    fix errors in s10, s37 field definitions (fr2.3.64, fr2.3.100).
dsm    5 $    these involve mb_chain for s10, vv_vbeg for s10 and s37.
dsm    6 $    deck affected - start.
dsm    7
rka    1
rka    2 $    rka       r. kenner           21 feb 79           level 79052
rka    3 $
rka    4 $    fix bug (fr2.3.97) in dsk code in emitsub which assumes that
rka    5 $    all registers contain data.
rka    6 $    fix bug (fr2.3.98) that had error count wrong in -aermey-.
rka    7 $    decks affected - emitsub, aermey.
rka    8
dsl    1
dsl    2 $    dsl       d. shields          01 feb 79           level 79032
dsl    3 $              r. kenner
dsl    4 $
dsl    5 $    1.  fix typo introduced by correction dsk.
dsl    6 $    2.  fix error (fr2.3.89) caused by wrongly removing 'if'
dsl    7 $        and 'ifnot' voa operations which branched to next operation.
dsl    8 $    decks affected - labfix, emitdop.
dsl    9
dsk    1 $    dsk       d. shields          30 jan 79           level 79030
dsk    2 $              r. kenner
dsk    3 $
dsk    4 $    1.  fix bug in setting drop status of temporaries (fr2.3.80).
dsk    5 $    2.  add code to support .sne. op (fr2.3.82).
dsk    6 $    3.  add option 'fag=0/1' which needs be set nonzero if
dsk    7 $        functions may alter globals (this required for setl cod, lib
dsk    8 $        phases).
dsk    9 $    4.  fix error (fr2.3.87) that resulted in bad code if multi-word
dsk   10 $        items compared in if statement.
dsk   11 $    5.  increase table dimensions so can digest setl.
dsk   12 $    6.  add field definitions for s32.
dsk   13 $    decks affected - macros, start, asmini, setup, asmprog, emitdop,
dsk   14 $        asmif, emitsub.
dsk   15
dsj    7
dsj    8 $    dsj       d. shields          27 dec 78           level 78361
dsj    9 $
dsj   10 $    1.  fix error (fr2.3.73) in emitsf that caused miscompilation
dsj   11 $        of lex.
dsj   12 $    2.  fix error (fr2.3.75) in sizing of last argument in
dsj   13 $        calls to getvar in some cases.
dsj   14 $    3.  expand operations aint, float, ifix, int (alias for ifix)
dsj   15 $        in-line.  this involves adding t10 opcodes ifr, rfi and rtr.
dsj   16 $    4.  provide code to translate little -amod- to opcode rmo, as
dsj   17 $        existing code was incomplete.
dsj   18 $    decks affected - macros, start, asmprog, emitdop, emitun, emitsf.
dsj   19
dsi    1
dsi    2 $    dsi       d. shields          20 dec 78           level 78354
dsi    3 $
dsi    4 $    1.  supply missing argument in -baseprober- call (fr2.3.69).
dsi    5 $    2.  supply missing argument in -ltlterm- call (fr2.3.70).
dsi    6 $    decks affected - macros, asmexit.
dsi    7
dsh    1
dsh    2 $    dsh       d. shields          19 dec 78           level 78353
dsh    3 $
dsh    4 $    1.  fix error (fr2.3.67) in that too many args were
dsh    5 $        passed to -cextmw-.
dsh    6 $    2.  fix error (fr2.3.68) in specification of attributes
dsh    7 $        of .e. assignment that caused fatal error in some cases.
dsh    8 $    decks affected - asmprog, emitdop.
dsh    9
dsg    1
dsg    2 $    dsg       d. shields          14 dec 78           level 78349
dsg    3 $              r. kenner
dsg    4 $
dsg    5 $    correct error (fr2.3.65) in translating assignment where
dsg    6 $    neither lastdrop set due to bug in -mover-.
dsg    7 $    deck affected - mover.
dsg    8
dsf    1
dsf    2 $    dsf       d. shields          12 dec 78           level 78346
dsf    3 $
dsf    4 $    fix error (fr2.3.63) that incorrectly declared -imo- to
dsf    5 $    be commutative.
dsf    6 $    deck affected - emitbin.
dsf    7
dse    1
dse    2 $    dse       d. shields          11 dec 78           level 78345
dse    3 $              r. kenner
dse    4 $
dse    5 $    1.  improve allocation of dead registers.
dse    6 $    2.  try once again to generate correct code for imt/idt (fr2.3.48)
dse    7 $    3.  fix bad code for some binary i/o (fr2.3.47)
dse    8 $        by moving  -kill(dopir)- to correct place in asmprog.
dse    9 $    4.  correct error (fr2.3.61) in compiling  .e. 1+e,3,mw(i) = 0,
dse   10 $        ie, .e. assign to indexed multiword where postion is expr.
dse   11 $    decks affected - asmprog, emitdop, emitbin, aermey.
dse   12
dsd    1
dsd    2 $    dsd       d. shields          08 dec 78           level 78342
dsd    3 $
dsd    4 $    1.  respond to fr 2.3.53 (mistranslation of easimw in lib) by
dsd    5 $        correcting code in -mover-.
dsd    6 $    2.  provide field definitions for asmif -it- table for s10, s66.
dsd    7 $    3.  correct conval test in asmfld (fr 2.3.60).
dsd    8 $    decks affected - asmif, asmfld, mover.
dsd    9
dsc    1
dsc    2 $    dsc       d. shields          27 nov 78           level 78331
dsc    3 $
dsc    4 $    1.  fix incorrect generation of imt to correct op imti.
dsc    5 $    2.  fix bug in emitbin which caused r-1 to be generated.
dsc    6 $    3.  fix bug in b$num call due to bad data statement.
dsc    7 $    decks affected - start, emitbin.
dsc    8
dsb    1
dsb    2 $    dsb       d. shields          25 sep 78           level 78268
dsb    3 $
dsb    4 $    1.  fix error which gave extra zero in label in  dwa  op.
dsb    5 $    2.  correct wrong name 'nbit$m' to be 'bnum$m'.
dsb    6 $    3.  change so dimltl not set by default, and so obtain
dsb    7 $        full length arrays for production use.
dsb    8 $    4.  add s10 fields for -mba-.
dsb    9 $    decks affected - start, endsubr.
dsb   10
dsa    5
dsa    6 $    dsa       d. shields          23 jun 78           level 78174
dsa    7 $
dsa    8 $    1.  correct error in documentation of -mvw- op.
dsa    9 $    2.  correct error in indexed multiword assignment that
dsa   10 $        caused bad translation of ltldoc.
dsa   11 $    decks affected - macros, asmxasi.
dsa   12
       3
       4 $    (none)    r. kenner           07 jun 78           level 78158
       5 $              d. shields
       6 $
       7 $    release initial version of dec-10 bootstrap compiler for
       8 $    checkout at university of leeds.
       9 $    little language level is 2.3; t10 target language level is 1.0.
      10 $    decks affected - all.
      11
      12
       1 .=member macros
       2
       3 .+set trace
       4 .+set labopt
       5 .+set ifopt
       6 .+set defer
       7
       8      +*  assemblerlevel =  $ define level of code generator.
pic    8          'asm(82244)'  $ 01-sep-82
      10          **
      11
dsvb   1 .+s32.
dsvb   2 .+set s32v  $ assume vms.
dsvb   3 ..s32
dsvb   4
dsvb   5 .+s32u.
dsvb   6 .+s32.
dsvb   7 .-set s32v  $ do not want vms.
dsvb   8 .+set s32u  $ want unix os.
dsvb   9 ..s32
dsvb  10 .+set mcl   $ want primary case to be lower.
dsvb  11 ..s32u
vaxa  12 .+s32.
vaxa  13 .+set t32
dst   22 .+set enp      $ support enp for s32
dsv   10 .+set t32h
vaxa  14 ..s32
vaxa  15
vaxa  16
eaa   33
eaa   34 .+t20.  $ if t20 initially set, select t10 (as t20 is extension of t10)
eaa   35 .+set t10
eaa   36 ..t20
eaa   37
vaxa  17 .+s10.
vaxa  18 .+set t10
vaxa  19 ..s10
vaxa  20
vaxa  21
vaxa  22 .-t32.
vaxa  23 .+set t10
vaxa  24 ..t32
vaxa  25
vaxa  26
vaxa  27 .+t10.
vaxa  28 .+s10.
vaxa  29 .+set hmeqtm    $ host machine = target machine
vaxa  30 ..s10
vaxa  31 ..t10
vaxa  32
vaxa  33
vaxa  34 .+t32.
vaxa  35 .+s32.
vaxa  36 .+set hmeqtm
dsq   36 .+set t32v  $ get vms format by default
vaxa  37 ..s32
vaxa  38 ..t32
vaxa  39
dsvb  12 .+s32u.
dsq   38 .-set t32v  $ disable vms format
dsq   39 .+set t32u  $ generate unix format t32
dsvb  13 ..s32u
dsq   41
dsu   28
dsu   29 .+t32v.
dsu   31 ..t32v
dsu   32
vaxa  40
      12      $   general macros.
      13
      14      +*  ws = .ws. **   $ machine word size.
      15      +*  ps = .ps. **   $ machine pointer size.
      16      +*  cs = .cs. **   $ machine character size.
      17
      18
      19      $   target machine parameters.
vaxa  41 .+t10.
      20      +*  mws = 36 **
      21      +*  mps = 18 **
dsp   26      +*  mcs = 09 **  $ 9 bit version
vaxa  42      +*  msl = 18 **
vaxa  43      +*  mso = 18 **
vaxa  44 ..t10
vaxa  45
eaa   38 .+t20  +*  mps = 30 **  $ increase mps for extended addressing
eaa   39
eaa   40
vaxa  46
vaxa  47 .+t32.
vaxa  48      +*  mws = 32 **
vaxa  49      +*  mps = 30 **
vaxa  50      +*  mcs = 8 **
vaxa  51      +*  msl = 16 **
vaxa  52      +*  mso = 16 **
vaxa  53 ..t32
vaxa  54
vaxa  55
      23      +*  mcpw = (mws/mcs) **  $ characters per word.
      24
      25      +*  no   = 0 **   $ logical false value.
      26      +*  yes  = 1 **   $ logical true value.
      27
      28      +*  namelen = 20 **  $ significant length of name.
dsn   20
dsn   21      +*  filenamelen = 20 **  $ lengt of file name.
dsn   22 .+s32 +*  filenamelen = 64 **
      29
dsn   23 $    getapp_len is length of actual parameter string (cf. lexini).
dsn   24          +*  getapp_len = 128  **
dsn   25 .+s32    +*  getapp_len = 240 **
dsn   26
      30      +*  lstimelen = 30 **  $ length of lstime result.
      31
      32      +*  slen = .len. **      $ length of self-defined string.
      33      +*  sorg = .f. .sl.+1, .so., **  $ origin of sds.
      34
      35      +*  cpw = (.ws./.cs.) **   $ number of characters/word.
      36
      37      $   meta macros.
      38      +*  q3(a, b, c) = a b c **
      39      +*  macdef(a) = q3(+, *a*, *) **
      40      +*  macdrop(a) = macdef(a=) **
      41      +*  defc(a) = macdef(a=zzya) **
      42      $   macros for -lcp- print package.
      43      +*  textl(s) = call textlr(s); **       $ print string.
      44      +*  charl(c) = call charlr(c); **       $ print character.
      45      +*  intl(i)  = call intlr(i); **        $ print integer.
      46      +*  intlp(i, n) = call intlpr(i, n); ** $ print -i- in -n- cols.
      47      +*  hexlp(w, n) = call hexlpr(w, n); **  $ print -w- hex -n- cols.
      48      +*  tintl(s, i) = call tintlr(s, i); ** $ print string and int.
      49      +*  endl  = call endlr; **              $ end current print line.
      50      +*  getlpos(n) = call contlpr(1, n); ** $ get current line pos.
      51      +*  setlpos(n) = call contlpr(2, n); ** $ set current line pos.
      52      +*  tabl(n)    = call contlpr(4, n); ** $ tab to column -n-.
      53      +*  ejectl     = call contlpr(5, 0); ** $ skip to new page.
      54      +*  ejectlp(n) = call contlpr(5, n); ** $ conditional eject.
      55      +*  listl(f)   = call contlpr(26,f); ** $ set list file control.
      56      +*  terml(f)   = call contlpr(27,f); ** $ set terminal file cntrl.
      57      +*  octl(i)  = call octlr(i); **        $ print octal.
      58      +*  octlp(i, n) = call octlpr(i, n); ** $ print -i- in -n- cols.
      59
      60      $   values for io access codes.
      61      +*  access_get  = 1 **
      62      +*  access_put = 3 **
      63      +*  access_read = 4 **
      64      +*  access_write = 6 **
      65      $   file numbers.
      66      +*  voafile = 3 **
      67      +*  codefile = 4 **  $ generated source code file (macro 10)
      68      +*  ocsfile = 5 **  $ string file for output code.
dst   23 .+enp      +*  enpfile = 6 **
dst   24 .+enp      +*  enpmax = 500 ** $ max. num. of procedures
      69
      70      $   tmc-del macros give delimiters for output constants.
dsn   27 .+t10    +*  tmccdel = 1r" **
vaxa  57 .+t32    +*  tmccdel = 1r" **
      72      +*  tmcsdel = 1r" **
dsq   42 .+hmeqtm.
dsq   43      +*  tmcctab = 9  **  $ tab character (assuming ascii).
dsq   44 ..hmeqtm
dsq   45 $    tmcscom is string giving comment character.
dsq   46 $    tmcsind is string giving 'indirection' character.
dsq   47 $    tmcslit is string giving 'constant literal character'.
dsq   48
dsq   49      +*  tmcscom = ';' **  $ default comment character.
dsq   50      +*  tmcsind = '@' **  $ default indirection character.
dsq   51      +*  tmcslit = '#' **  $ default constant literal character.
dsq   52
dsq   53 .+t32u.
dsq   54 $    redefine codes for t32u assembler.
dsq   55      +*  tmcscom = '#' **  $ comment character
dsq   56      +*  tmcsind = '*' **  $ indirection character.
dsq   57      +*  tmcslit = '$' **  $ constant literal character.
dsr   10      $   the s66 used to maintain source does not have grave
dsr   11      $   accent, so use ascii code.
dsr   12      +*  tmccgra = 3b'140' **  $ grave accent (ascii octal 140)
dsq   58 ..t32u
      73
      74      $   mneg computes two complement value of negative offset.
vaxa  58      +*  mneg(x) =
vaxa  59 .+t10    (3b'1000000' - (x))
vaxa  60 .+t32.
vaxa  61 .+hmeqtm (-(x))
vaxa  62 .-hmeqtm (4b'100000000' - (x))
vaxa  63 ..t32
vaxa  64          **
      76
      77      $   dimensions of tables.
      78
      79 $ select dimltl for small, test dimensions.
      81 .-dimltl.
dso   10      +*  hadim = 937 **
      83      +*  mbadim = 63 **
      84      +*  namesdim = 800 **
      85      +*  valdim = 1100 **
      86      +*  voadim = 1850 **
      87      +*  xargdim = 511 **
      88
      89      +*  dopsdim = 32 **
dsk   17      +*  ditemdim = 90 **
dsk   18      +*  dworddim = 220 **
dsk   19      +*  dregdim = 220 **
      93      +*  lablistdim = 400 **
dsk   20      +*  pdlistdim = 500 **
      95      +*  pcaradim = 6 **
      96 ..dimltl
      97
      98 .+dimltl.
dso   11      +*  hadim = 937 **
     100      +*  mbadim = 63 **
     101      +*  namesdim = 300 **
     102      +*  valdim = 400 **
     103      +*  voadim = 500 **
     104      +*  xargdim = 200 **
     105
     106      +*  dopsdim = 32 **
     107      +*  ditemdim = 40 **
     108      +*  dworddim = 50 **
     109      +*  dregdim = 50 **
     110      +*  lablistdim = 100 **
     111      +*  pdlistdim = 200 **
     112      +*  pcaradim = 6 **
     113 ..dimltl
     114
     115
     116      $   register numbers.
     117
     118      $   the following macros encode register numbers.  the dec-10
     119      $   contains 16 accumulators.  this asm only uses some of the
     120      $   registers, in the range r0 to rhi.  the asm also requires
     121      $   a 'spare' register, assumed to be rhi+1.  the spare register
     122      $   is used to construct parameter lists and to store values in
     123      $   some situations.
     124
vaxa  65 .+t10.
     125      +*  r0  =  1 **  $ first register, used for function value.
     126      +*  r1  =  2 **  $ first assignable register.
     127      +*  rlo = r1 **  $ first assignable register (ac 1).
     128      +*  rhi = 12 **  $ last assignable register (ac 11).
     129      +*  parmreg = rhi  **  $ contains parameter list address.
     130      +*  sparereg = (rhi+1) **  $ spare register.
     131      +*  rhihi = 16 **  $ last machine register (ac 15).
vaxa  66 ..t10
vaxa  67
vaxa  68
vaxa  69 .+t32.
vaxa  70      +*  r0  =  1 **  $ first register, used for function value.
vaxa  71      +*  r2  =  3 **  $ first assignable register.
vaxa  72      +*  rlo = r2 **  $ first assignable register
vaxa  73      +*  rhi = 12 **  $ last assignable register
vaxa  74      +*  parmreg = 13  **  $ contains parameter list address.
vaxa  75      +*  sparereg = 2 **  $ spare register.
vaxa  76      +*  rhihi = 16 **  $ last machine register
vaxa  77 ..t32
     132
     133      $   machine block types.
     134
     135      +*  bl_abs    =  0 **  $ absolute block.
     136      +*  bl_imm    =  1 **  $ immediate constant block.
     137      +*  bl_base   =  2 **  $ base block.
     138      +*  bl_const  =  3 **  $ constant block.
     139      +*  bl_temp   =  4 **  $ temporary block.
     140      +*  bl_local  =  8 **  $ local variable blokck.
     141      +*  bl_global = 10 **  $ first global block.
     142
     143      +*  num_bl = 4 **  $ number of special blocks.
     144
     145      $   -voa-  operations.
     146
     147      +*  vo_add    =  1 **       +*  vo_xload  = 31 **
     148      +*  vo_sub    =  2 **       +*  vo_xasin  = 32 **
     149      +*  vo_gt     =  3 **       +*  vo_xfasin = 33 **
     150      +*  vo_lt     =  4 **       +*  vo_ifnot  = 34 **
     151      +*  vo_ge     =  5 **       +*  vo_ccat   = 35 **
     152      +*  vo_le     =  6 **       +*  vo_in     = 36 **
     153      +*  vo_eq     =  7 **       +*  vo_eext   = 37 **
     154      +*  vo_ne     =  8 **       +*  vo_sext   = 38 **
     155      +*  vo_mul    =  9 **       +*  vo_easin  = 39 **
     156      +*  vo_div    = 10 **       +*  vo_sasin  = 40 **
     157      +*  vo_or     = 11 **       +*  vo_xeasin = 41 **
     158      +*  vo_seq    = 12 **       +*  vo_xsasin = 42 **
     159      +*  vo_and    = 13 **       +*  vo_radd   = 43 **
     160      +*  vo_exor   = 14 **       +*  vo_rsub   = 44 **
     161      +*  vo_sne    = 15 **       +*  vo_rgt    = 45 **
     162      +*  vo_nb     = 16 **       +*  vo_rlt    = 46 **
     163      +*  vo_fb     = 17 **       +*  vo_rge    = 47 **
     164      +*  vo_not    = 18 **       +*  vo_rle    = 48 **
     165      +*  vo_fcall  = 19 **       +*  vo_req    = 49 **
     166      +*  vo_scall  = 20 **       +*  vo_rne    = 50 **
     167      +*  vo_asin   = 21 **       +*  vo_rmul   = 51 **
     168      +*  vo_data   = 22 **       +*  vo_rdiv   = 52 **
     169      +*  vo_fasin  = 23 **       +*  vo_rusub  = 53 **
dsj   21                                  +*  vo_float  = 54 **
dsj   22                                  +*  vo_ifix   = 55 **
     170      +*  vo_io     = 24 **       +*  vo_abs    = 56 **
     171      +*  vo_return = 25 **       +*  vo_iabs   = 57 **
dsj   23                                  +*  vo_aint   = 58 **
dsj   24                                  +*  vo_int    = 59 **
dsj   25                                  +*  vo_amod   = 60 **
     172      +*  vo_fext   = 26 **       +*  vo_mod    = 61 **
     173      +*  vo_if     = 27 **       +*  vo_sign   = 62 **
     174      +*  vo_lab    = 28 **       +*  vo_isign  = 63 **
     175      +*  vo_goto   = 29 **       +*  vo_dim    = 64 **
     176      +*  vo_goby   = 30 **       +*  vo_idim   = 65 **
     177
     178      +*  num_vo = 65 **   $ number of operations.
     179
     180      $   deferred operation codes.
     181
     182 .=zzyorg a
     183 $    deferred operation codes
     184
     185 .=zzyorg a
     186      defc(do_add)
     187      defc(do_sub)
     188      defc(do_lt)
     189      defc(do_ge)
     190      defc(do_eq)
     191      defc(do_ne)
     192      defc(do_mul)
     193      defc(do_div)
     194      defc(do_and)
     195      defc(do_or)
     196      defc(do_exor)
     197      defc(do_fcall)
     198      defc(do_nb)
     199      defc(do_not)
     200      defc(do_fb)
     201      defc(do_scall)
     202      defc(do_asin)
     203      defc(do_fasin)
     204      defc(do_return)
     205      defc(do_fext)
     206      defc(do_if)
     207      defc(do_goto)
     208      defc(do_xload)
     209      defc(do_xasin)
     210      defc(do_xfasin)
     211      defc(do_ifnot)
     212      defc(do_eext)
     213      defc(do_easin)
     214      defc(do_xeasin)
     215      defc(do_xsasin)
     216      defc(do_radd)
     217      defc(do_rsub)
     218      defc(do_rlt)
     219      defc(do_rge)
     220      defc(do_req)
     221      defc(do_rne)
     222      defc(do_rmul)
     223      defc(do_rdiv)
     224      defc(do_rusub)
     225      defc(do_abs)
dsj   26      defc(do_float)
dsj   27      defc(do_ifix)
dsj   28      defc(do_aint)
dsj   29      defc(do_amod)
     226      defc(do_iabs)
     227      defc(do_mod)
     228      defc(do_sign)
     229      defc(do_isign)
     230      defc(do_dim)
     231      defc(do_idim)
     232      defc(do_seq)
     233      defc(do_sne)
     234      defc(do_goby)
     235
     236      +*  num_do  = do_goby  **  $ number of dops.
     237
     238      $   assembler operations.
     239
     240 .=zzyorg a
     241
     242      defc(ao_ban)
     243      defc(ao_bor)
     244      defc(ao_bxo)
     245      defc(ao_idi)
     246      defc(ao_idt)
     247      defc(ao_ieq)
     248      defc(ao_ige)
     249      defc(ao_igt)
     250      defc(ao_ile)
     251      defc(ao_ilt)
     252      defc(ao_imu)
     253      defc(ao_imt)
     254      defc(ao_isi)
     255      defc(ao_ine)
     256      defc(ao_isu)
     257      defc(ao_iad)
     258      defc(ao_imo)
     259      defc(ao_rmo)
     260      defc(ao_rad)
     261      defc(ao_rdi)
     262      defc(ao_req)
     263      defc(ao_rge)
     264      defc(ao_rgt)
     265      defc(ao_rle)
     266      defc(ao_rlt)
     267      defc(ao_rmu)
     268      defc(ao_rne)
     269      defc(ao_rsi)
     270      defc(ao_rsu)
     271      defc(ao_bfb)
     272      defc(ao_bnb)
     273      defc(ao_bno)
     274      defc(ao_iab)
     275      defc(ao_iao)
     276      defc(ao_ico)
dsj   30      defc(ao_ifr)
     277      defc(ao_iso)
     278      defc(ao_rab)
     279      defc(ao_rco)
dsj   31      defc(ao_rfi)
dsj   32      defc(ao_rtr)
     280      defc(ao_ldf)
     281      defc(ao_lpr)
     282      defc(ao_cal)
     283      defc(ao_mvw)
     284      defc(ao_zeb)
     285      defc(ao_stf)
     286      defc(ao_spr)
     287
     288      +*  ao_fbo = ao_ban **  $ first binary op
     289      +*  ao_lbo = ao_rsu **  $ last binary op
     290      +*  ao_fuo = ao_bfb **  $ first unary op
     291      +*  ao_luo = ao_lpr **  $ last unary op
vaxa  78      +*  num_ao = ao_spr **  $ number of ao operators
     293
     294
     295      $   machine operation codes (listed in alphabetical order)
     296
     297 .=zzyorg a
     298
     299      defc(mo_ban)
     300      defc(mo_bfb)
     301      defc(mo_bnb)
     302      defc(mo_bno)
     303      defc(mo_bor)
     304      defc(mo_bxo)
     305      defc(mo_cal)
     306      defc(mo_ceq)
     307      defc(mo_cge)
     308      defc(mo_cgt)
     309      defc(mo_cle)
     310      defc(mo_clt)
     311      defc(mo_cne)
     312      defc(mo_iab)
     313      defc(mo_iad)
     314      defc(mo_iao)
     315      defc(mo_ico)
     316      defc(mo_idi)
     317      defc(mo_idt)
     318      defc(mo_ieq)
dsj   33      defc(mo_ifr)
     319      defc(mo_ige)
     320      defc(mo_igt)
     321      defc(mo_ile)
     322      defc(mo_ilt)
     323      defc(mo_imo)
     324      defc(mo_imt)
     325      defc(mo_imu)
     326      defc(mo_ine)
     327      defc(mo_isi)
     328      defc(mo_iso)
     329      defc(mo_isu)
     330      defc(mo_jeq)
     331      defc(mo_jge)
     332      defc(mo_jgt)
     333      defc(mo_jle)
     334      defc(mo_jlt)
     335      defc(mo_jmn)
     336      defc(mo_jmp)
     337      defc(mo_jne)
     338      defc(mo_lda)
     339      defc(mo_ldf)
     340      defc(mo_ldl)
     341      defc(mo_ldr)
     342      defc(mo_ldw)
eaa   41 .+t20       defc(mo_lla)
     343      defc(mo_lpr)
     344      defc(mo_mvw)
dsu   33      defc(mo_mvx)
     345      defc(mo_rab)
     346      defc(mo_rad)
     347      defc(mo_rco)
     348      defc(mo_rdi)
     349      defc(mo_req)
     350      defc(mo_ret)
dsj   34      defc(mo_rfi)
     351      defc(mo_rge)
     352      defc(mo_rgt)
     353      defc(mo_rle)
     354      defc(mo_rlt)
     355      defc(mo_rmo)
     356      defc(mo_rmu)
     357      defc(mo_rne)
     358      defc(mo_rsi)
     359      defc(mo_rsu)
dsj   35      defc(mo_rtr)
     360      defc(mo_spr)
     361      defc(mo_stf)
     362      defc(mo_stl)
vaxa  79 .+t32    +*  mo_xjm = mo_str **   $ add new opcode for t32.
     363      defc(mo_str)
     364      defc(mo_stw)
     365      defc(mo_zeb)
eaa   42 .+t20   defc(mo_hba)
eaa   43 .+t20   defc(mo_hbb)
eaa   44 .+t20   defc(mo_hbc)
     366      defc(mo_zew)
     367
     368      +*  num_mo = mo_zew **  $ number of mo ops
     369
     370
     371
     372      $   mop attributes are given by following macros and fields.
     373      +*  moaimm(mop) = moa_imm moatab(mop)  **  $ is immediate ok.
     374      +*  moaicb(mop) = mob_icb moatab(mop)  **  $ basic instruction cod
     375      +*  moaici(mop) = moa_ici moatab(mop) ** $ immediate instr. code.
     376      +*  moaiwc(mop) = moa_iwc moatab(mop) **  $ instr. word count.
     377
     378      +*  moa_imm = .f. 01, 1, **  $ on if immediate mode allowed.
     379      +*  moa_ici = .f. 04, 9, **  $ opcode if moa_imm set.
     380      +*  moa_icb = .f. 13, 9, **  $ basic instruction code.
     381      +*  moa_iwc = .f. 22, 3, **  $ instruction word count.
     382
     383
     384      $   the following branch masks are used to select various types
     385      $   of conditional branches.  they are three bits long.  each
     386      $   bit means branch on <0, =0, or >0.  therefore, all bits being
     387      $   set is an unconditional branch.  therefore, to negate a branch
     388      $   mask, it must just be exclusive or'ed with the unconditional
     389      $   mask.  an extra branch mask is used to indicate the mask for
     390      $   the 'testchar' test when the bits are on.
     391      $   [these codes used in asmif, branchr.]
     392
     393      +*  bm_zer = 1b'100'  **  $ branch on zero.
     394      +*  bm_neg = 1b'010'  **  $ branch on less than zero.
     395      +*  bm_pos = 1b'001'  **  $ branch on greater than zero.
     396      +*  bm_all = 1b'111'  **  $ unconditional branch.
     397
     398      +*  binv(bm) =  (bm .ex. bm_all) **  $ inverse branch mask.
     399
     400      +*  bmswap(bm, t) =     $ swap branch mask.
     401          $   this is used when one wants to reverse the operands of
     402          $   a comparison.  it changes the positive and negative bits.
     403          $   -bm- is the output and input mask and -t- is a temporary.
     404          t = bm;  .f. 1, 1, t = .f. 2, 1, bm;
     405          .f. 2, 1, t = .f. 1, 1, bm;  bm = t;
     406          **
     407
     408
     409      $   these macros are used to emit -asm- instructions to be
     410      $   converted into dec-10 machine code.  they are split up into
     411      $   various types and each has its own macro.  the operations
     412      $   of that type all call that macro.  note that not all
     413      $   operations have macros because only those that are issue
     414      $   explicitly (i.e., not from a table) have macros defined.
     415
     416
     417      $   these macros are for the conditional operations.  the first
     418      $   parameter after the op-code is the dummy register to be tested
     419      $   and the second parameter is the label to branch to if the
     420      $   test is true.
     421
     422      +*  if_op(op, in, lab) = call emitif(op, in, lab); **
     423
     424      +*  ifspos_op(in, lab) =  $ branch to -lab- if -in- is >0.
     425          if_op(bm_pos, in, lab) **
     426
     427      +*  ifpos_op(in, lab) =   $ branch to -lab- if -in- is >=0.
     428          if_op(binv(bm_neg), in, lab) **
     429
     430      +*  goto_op(lab) =  $ unconditional branch to -lab-.
     431          branchop(bm_all, r0, lab) **  $ unconditional branch.
     432
     433
     434      $   these next macros are for the long operations.  these
     435      $   operations are storage-storage operations.  the first
     436      $   parameter after the op-code is the address of the destination,
     437      $   the second is the address of the target, and the last is the
     438      $   length in words.  the addresses are obtained via the -getaddr-
     439      $   macro.
     440
     441      +*  long_op(op, or, ir, l) =
     442          call emitlong(op, or, ir, l); **
     443
     444      +*  smove_op(or, ir, l) =  $ move from input to output.
     445          long_op(ao_mvw, or, ir, l); **
     446
     447      +*  clear_op(r, l) =  $ clear to zero.
     448          long_op(ao_zeb, r, r, l); **
     449
     450      $   the clear op clears nw words of memory.
     451
     452
     453      $   these macros are for unary operators.  the first parameter
     454      $   after the op-code is the output and the last parameter is the
     455      $   input operand.
     456
     457      +*  un_op(op, or, ir) = call emitun(op, or, ir); **
     458
     459      +*  not_op(or, ir) =  $ negate (not complement) register.
     460          un_op(ao_bno, or, ir) **
     461
     462      +*  neg_op(or, ir) =   $ complement register (0-r).
     463          un_op(ao_ico, or, ir) **
     464
     465      +*  add1_op(or, ir) =  $ add one to a register.
     466          un_op(ao_iao, or, ir) **
     467
     468      +*  sub1_op(or, ir) =  $ subtract one from a register.
     469          un_op(ao_iso, or, ir) **
     470
     471      $   the lpr and spr ops retrieve/store parts of registers.
     472      $   lpr loads from ir to or, spr stores from or to ir, ie
     473      $   lpr_op(r1,r2,c1,c2)  <-> r1 = .f. c1+1, c2, r1
     474      $   spr_op(r1,r2,c1,c2)  <-> .f. c1+1, c2, r2 = r1
     475
     476      +*  lpr_op(or, ir, fo, fl) =  $ load part of word.
     477          emopparm1 = fo;  emopparm2 = fl;  $ set extra parms.
     478          un_op(ao_lpr, or, ir)  **  $ do as unary op.
     479
     480      +*  ldf_op(or, ir) =  $ load -or- as pointed to by byte -ir-.
     481          un_op(ao_ldf, or, ir) **  $ do as unary op.
     482
     483      $   macros for part word store operations.
     484
     485      +*  sfld_op(op, ir, tr) =  $ store -ir- into -tr-
     486          call emitsfld(op, ir, tr);  **
     487
     488      +*  spr_op(ir, tr, fo, fl) =  $ store part of word.
     489          emopparm1 = fo;  emopparm2 = fl;  $ set extra parms.
     490          sfld_op(ao_spr, ir, tr) **  $ do operation
     491
     492      +*  stf_op(ir, tr) =  $ store -ir- in byte pointed to by -tr-.
     493          sfld_op(ao_stf, ir, tr) **  $ do operation
     494
     495
     496      $   these macros are for the subroutine handling operations
     497      $   such as call.
     498
     499      +*  call_op = call emitsub; **
     500
     501
     502      $   these macros are used to emit binary operations.  the first
     503      $   parameter after the op-code is the output and the last two
     504      $   parameters are the inputs.
     505
     506      +*  bin_op(op, out, in1, in2) = call emitbin(op, out, in1, in2);**
     507
     508      +*  and_op(out, in1, in2) =  $ logical -and-
     509          bin_op(ao_ban, out, in1, in2) **
     510
     511      +*  or_op(out, in1, in2) =   $ logical -or-
     512          bin_op(ao_bor, out, in1, in2) **
     513
     514      +*  exor_op(out, in1, in2) =   $ logical exclusive -or-.
     515          bin_op(ao_bxo, out, in1, in2) **
     516
     517      +*  add_op(out, in1, in2) =  $ addition.
     518          bin_op(ao_iad, out, in1, in2) **
     519
     520      +*  sub_op(out, in1, in2) =  $ subtraction.
     521          bin_op(ao_isu, out, in1, in2) **
     522
     523      +*  mul_op(out, in1, in2) =   $ multiplication
     524          bin_op(ao_imu, out, in1, in2) **
     525
     526      +*  div_op(out, in1, in2) =   $ division
     527          bin_op(ao_idi, out, in1, in2) **
     528
     529      +*  mul2_op(out, in1, in2) =   $ multiplication by power of two
     530          bin_op(ao_imt, out, in1, in2) **
     531
     532      +*  div2_op(out, in1, in2) =   $ division by power of two
     533          bin_op(ao_idt, out, in1, in2) **
     534
     535      +*  mod_op(out, in1, in2) =   $ mod
     536          bin_op(ao_imo, out, in1, in2) **
     537
     538
     539      $   the next operation compares two inputs and branches
     540      $   with a specified condition to a label.
     541      +*  cmp_op(bm, in1, in2, lab) =
     542          call emitcmp(bm, in1, in2, lab);  **
     543
     544
     545      $   macro to assign dummy resister to -voa- operand
     546
     547      $   the -assign- macro has two operands.  the first rs the
     548      $   variable to receive the dummy register number and the
     549      $   second is the encoded -voa- operand to obtain.  the
     550      $   encodings follow.
     551
     552      +*  va_spec = 1 **  $ special value.  use -voaep- as pointer.
     553      +*  va_fnct = 2 **  $ function return (voap=1)
     554      +*  va_inp1 = 3 **  $ input one of current operation
     555      +*  va_inp2 = 4 **  $ input two
     556      +*  va_inp3 = 5 **  $ input three
     557      +*  va_inp4 = 6 **  $ input four
     558      +*  va_oup  = 7 **  $ output
     559      +*  va_xarg = 8 **  $ values above this indicate that arguments
     560                          $ come from the -xarg- entries pointed to by
     561                          $ the current operation.  the difference
     562                          $ between the value and -va_xarg- is the
     563                          $ number of the desired parameter.
     564
     565
     566      +*  assign(reg, type) =
     567          call assignr(type);  $ call routine to get register.
     568          reg = assignreg;  ** $ copy assigned value.
     569
     570
     571
     572      $   macro to assign dummy register to constant.
     573
     574      $   the -assignconst- macro has two operands.  the first is set
     575      $   to the number of the dummy register assigned.  the second
     576      $   operand is the constant to be assigned to the register.
     577      $   the flag -asconstspc- is used internally to alter the meaning
     578      $   of the second operand.  see routines -assignr- and -asconst-
     579      $   for meaning of this usage.
     580
     581      +*  assignconst(reg, const) =  $ assign register to constant.
     582          call asconst(const);  $ pass constant to routine.
     583          reg = asconstreg; **  $ get return value.
     584
     585
     586      $   macro to get free dummy register.
     587
     588      $   the -getdreg- macro gets a dummy register to use as a
     589      $   temporary result.  it is set up as a one word variable
     590      $   with standard form, offset, etc.  this variable is set to
     591      $   temporary type and, when actually used as core reference,
     592      $   will be allocated to an actual temporary location, if needed.
     593
     594      +*  getdreg(reg) =  $ get dummy register.
     595          call getdregr(reg); **   $ call routine.
     596
     597
     598      $   macro to clear dummy register.
     599
     600      $   the -clear- macro resets the status of a dummy register so
     601      $   that it can be assigned to.  this involves dropping any
     602      $   alternate forms and/or deferred operations from the previous
     603      $   value of the register.
     604
     605      +*  clear(reg) = call clearr(reg); **  $ call routine.
     606
     607
     608
     609      $   -getdesc- macro.
     610
     611      $   the -getdesc- macro gets a description of the variable
     612      $   given to it.  the description is given by three items.  the
     613
     614      +*  getdesc(dr, typ, ind, reg, off) =
     615          call getdescr(dr, typ, ind, reg, off); **  $ call routine.
     616
     617
     618
     619      $   -getvar- macro
     620
     621      $   the -getvar- macro is similar to the -getdesc- macro in its
     622      $   parameters.  the difference is that -getvar- can be used oto
     623      $   put the variable into the desired type of register.  it
     624      $   should be called when the type is anything other than
     625      $   -gd_addr-.
     626
     627      +*  getvar(dr, typ, mode, reg, off) =
     628          call getvarr(dr, typ, mode, reg, off); **
     629
     630
     631      $   types for -getdesc- and -getvar-
     632
     633      +*  gd_addr    = 1 **  $ just get address pointer.
     634      +*  gd_use     = 2 **  $ want to use variable as general.
     635      +*  gd_reg     = 3 **  $ force into register.
     636      +*  gd_intoreg = 4 **  $ want to load into specific register.
     637      +*  gd_inregnu = 5 **  $ want to load specific register, no upd.
     638
     639      +*  num_gd = 5 **  $ number of types.
     640
     641      $   macro -countup-.
     642
     643      $   increment a pointer to an array and
     644      $   to test for array overflow.
     645
     646      +*  countup(p, max, name) =
     647          p = p+1;  $ increment pointer.
     648          if  (p > max) call countupr(name);  $ error.
     649          **
     650
     651      $   macro -lastuse-.
     652
     653      $   this macro is used to indicate that the next action done
     654      $   by a generator on a dummy register will be its last.
     655
     656      +*  lastuse(reg) =
     657          di_luse ditem(dr_item dreg(reg)) =   $ increment.
     658              di_luse ditem(dr_item dreg(reg)) + 1;
     659          **
     660
     661
     662
     663      $   macro -sdsname-.
     664
     665      $   this macro returns an sds containing the name of the item
     666      $   whose -ha- pointer is given.  (it must be a variable or
     667      $   routine name.)
     668      $   sdsname is used for names to appear in generated code file,
     669      $   so that long names are truncated to six characters.
     670
     671      +*  sdsname(str, ptr) =
     672          call sdsnamr(str, ptr);  $ call routine.
     673          **
     674
     675      $   macro -sdlname-.
     676
     677      $   this macro returns an sds containing the name of the item
     678      $   whose -ha- pointer is given.  (it must be a variable or
     679      $   routine name.)
     680
     681      +*  sdlname(str, ptr) =
     682          call sdlnamr(str, ptr);  $ call routine.
     683          **
     684
     685
     686 .+defer.
     687      $   -using- macro.
     688
     689      $   the -using- macro is used to indicate that an operand of
     690      $   a previous deferred operation is going to be used even
     691      $   though the operation may be freed.  this is needed to
     692      $   keep track of the count fields.
     693
     694      +*  using(dr) =   $ will use this register.
     695          di_count ditem(dr_item dreg(dr)) =    $ increment count.
     696              di_count ditem(dr_item dreg(dr)) + 1;
     697          **
     698 ..defer
     699
     700
     701
     702      $   thdse are access macros for various fields in -ditem-.
     703      $   they enable them to be accessed from the -dreg- pointer.
     704
     705      +*  accss(fld, dr) = fld ditem(dr_item dreg(dr)) **
     706
     707      +*  nwords(dr) = accss(di_nwords, dr) **
     708
     709      +*  syze(dr) = accss(di_syze, dr) **
     710
     711      +*  conval(dr) = accss(di_cval, dr) **
     712
     713 .+defer  +*  dout(dr) = accss(di_out, dr) **
     714
     715      +*  isreal(dr) = accss(di_real, dr) **
     716
     717      +*  ismw(dr) = accss(di_mw, dr) **
     718
     719      +*  isvar(dr) = accss(di_var, dr) **
     720
     721      +*  istemp(dr) = accss(di_temp, dr) **
     722
     723      +*  isconst(dr) = accss(di_const, dr) **
     724
     725      +*  isscon(dr) = accss(di_scon, dr) **
     726
     727      +*  isind(dr) = (accss(di_anum, dr) ^= 0) **
     728
     729
     730
     731      $   macro -getwordc-.
     732
     733      $   this macro is called by a set of macros to address words or
     734      $   parts of words.  the first parameter of these macros is
     735      $   the 'output' register, the second is the 'input' register,
     736      $   the third is the word of character offst of the word or
     737      $   character desired, and the fourth is the -dreg- number of an
     738      $   optional index register.
     739
     740      $   ****** important note ******
     741      $   [ds 11 apr  ds will see kenner about this important note
     742      $   and report back to mccann.]
     743      $   the -getaddr- and -getword- calls return a form of
     744      $   the input when there is no index.  thus if the argument
     745      $   is slated to be dropped, things will blow up.  the solution
     746      $   is not to drop the argument unless there is an index.
     747      $   if ind is zero, then dritem(out) is same as dritem(in);
     748      $   otherwise, a 'special' temporary is built.  hennce can
     749      $   cannot do lastuse(out) unless you mean lastuse(in) also.
     750      +*  getwordc(type, out, in, off, ind) =  $ first parm. is type.
     751          call getwordr(out, in, type, off, ind); **   $ call routine.
     752
     753
     754      $   types for -getwordc-.
     755
     756      +*  gw_word  = 01 **  $ get word value.
     757      +*  gw_addr  = 02 **  $ get word address.
     758      +*  gw_sword = 03 **  $ store word.
     759
     760      +*  num_gw = 3 **
     761
     762      +*  getword(out, in, off, ind) =
     763          getwordc(gw_word, out, in, off, ind) **
     764      +*  getaddr(out, in, off, ind) =
     765          getwordc(gw_addr, out, in, off, ind) **
     766      +*  storeword(out, in, off, ind) =
     767          getwordc(gw_sword, out, in, off, ind) **
     768
     769
     770      $   macro -branchop-.
     771
     772      $   this macro is used to generate a branch to a desired label.
     773      $   the first parameter is the hardware condition code mask to
     774      $   use for the branch and the second parameter is the label
     775      $   number.
     776
     777      +*  branchop(m, reg, lab) = call branchr(m, reg, lab); **
     778
     779
     780      $   macros for emitting machine operations.
     781
     782      +*  emop(op, oreg, imode, ireg, ioff) = $ emit basic machine op.
     783          call emopr(op, oreg, imode, ireg, ioff); **
     784
     785
     786      $   -move_op- macro.
     787
     788      $   this macro is used to move the contents of one dummy register
     789      $   to another.  the first operand is the output register and the
     790      $   second is the input rwegister.
     791
     792      +*  move_op(out, in) = call mover(out, in); **
     793
     794
     795
     796      $   -inzero- macro.
     797
     798      $   the macro is called to indicate that a value is present in
     799      $   machine register zero.  if the second operand is yes, the
     800      $   address of the operand (assumed multi-word) is in reg zero.
     801
     802      +*  inzero(dr, fl) = call inzeror(dr, fl); **
     803
     804
     805      $   the mrcopy macros is used to copy one register to another.
     806      +*  mrcopy(a,b) = $ copy reg b to reg a.
     807          if  a^=b  then  $ copy only if regs differ.
     808              emop(mo_ldw, a, am_reg, b, 0);
     809              end if; **
     810
     811      $   the mrclear macro clears a register.
     812      +*  mrclear(a) = emop(mo_zew, a, am_reg, a, 0); **
     813
     814      $   -forcezero- macro.
     815
     816      $   this macro is used to force a variable into register zero,.
     817      $   it is used in some function returns and for some special
     818      $   calling sequences.  the first parameter is the variable and
     819      $   the second is a flag which is set if the address of the
     820      $   variable is what is wanted in register zero.
     821
     822      +*  forcezero(dr, fl) = call forcer(dr, fl); **
     823
     824
dss   14      +*  labcol = 3 **  $ columns for label
dss   15 .+t32u +* labcol = 5 **
     825
     826      $   -labfree- macro.
     827
     828      $   this macro is used to release a label that was used
     829      $   temporarily in a local fashion.
     830
     831      +*  labfree(l) =   $ free a label.
     832          ; **
     833
     834
     835
     836      $   -labget- macro.
     837
     838      $   this macro gets a temporary label for local use.
     839
     840      +*  labget(l) =   $ get a temporary label.
     841
     842              countup(labluse, lablistdim, 'lablist');
     843              l = labluse;  $ set to gotten label.
     844              lablist(l) = 0;  $ clear label list entry.
     845          **
     846
     847
     848
     849      $   -labdef- macro.
     850
     851      $   this macro is used to define the position of a label.  the
     852      $   first operand is the label number and the second operand is a
     853      $   flag which is off when the label is only being used for
     854      $   internal local purposes.
     855
     856      +*  labdef(l, f) = call labdefr(l, f); **
     857
     858
     859      $   -store- macro.
     860
     861      $   this macro is used to store the live data in the machine
     862      $   register given by its first parameter into the dummy register
     863      $   location indicated by its second parameter.  status values
     864      $   are reset appropriately.
     865      $   see dropr, getwordr, storall, emitlong, emitsub, getdregr,
     866      $   endsubr
     867
     868      +*  store(mr, dr) = call storer(mr, dr); **
     869
     870
     871
     872      $   -getreg- macro.
     873
     874      $   this macro is used to obtain a register of a desired type.
     875      $   the first parameter will contain the register obtained and
     876      $   the second parameter is the type.
     877      $   if no registers of
     878      $   that type or lower are available, a value of zero will be
     879      $   given for the register.  specifying the type as a 'live'
     880      $   type will ensure that a register will always be obtained.
     881
     882      +*  getreg(mr, typ) = call getregr(typ); mr = gotreg;**
     883
     884
     885
     886      $   -lastdrop- macro.
     887
     888      $   this macro sees if this is last use of dummy register.
     889
     890      +*  lastdrop(dr) =
     891          ( (di_count ditem(dr_item dreg(dr))=1
     892          & di_ldrop ditem(dr_item dreg(dr))
     893          & di_luse ditem(dr_item dreg(dr)) ^= 0)
     894          ! ismw(dr) ! isscon(dr) )  **
     895
     896
     897      $   -dropform- macro.
     898
     899      $   this macro is used to drop a dummy register.
     900
     901      +*  dropform(dr)  =
     902          if  (dr_reg dreg(dr)) reglis(dr_reg dreg(dr)) = 0;
     903
     904          $   put this dummy register onto free list.
     905          dreg(dr) = 0;   $ clear out all status info.
     906          dr_next dreg(dr) = dregfree;  $ chain to rest of free list.
     907          dregfree = dr;  $ put onto free list.
     908          **
     909
     910
     911
     912      $   -drop- macro.
     913
     914      $   this macro is used to drop an entire dummy register.  it
     915      $   drops all the forms in the chain and also, if there is one,
     916      $   any deferred operations that this is the output of.
     917
     918      +*  drop(dr) =
     919          if  (di_luse ditem(dr_item dreg(dr)) ^= 0)  $ can drop.
     920              call dropr(dr);   $ call routine to drop.
     921          **
     922
     923
     924
     925      $   -kill- macro.
     926
     927      $   this macro is the same as -drop- except that it does not
     928      $   require that the generator have dropped the register.  it
     929      $   is used in place of -lastuse-, -drop- sequences.
     930
     931      +*  kill(dr) =  call dropr(dr); **
     932
     933
     934
     935 .+defer.
     936      $   -dropdop- macro.
     937
     938      $   this macro drops a deferred operation.  it will also drop any
     939      $   registers that are inputs to that operation.
     940
     941      +*  dropdop(dop) = dropdopflg = yes;   call dropr(dop); **
     942 ..defer
     943
     944
     945
     946 .+eab. $ put off until after bootstrap, no need for pairs now.
     947      $   -getregpair- macro.
     948
     949      $   this macro is used to return a free even/odd pair of
     950      $   registers.  the even register is returned in the first
     951      $   parameter.  the other two parameters are registers that can
     952      $   be used in the pair.  both registers are freed and on hold
     953      $   when returned and if either of the two registers matched one
     954      $   of the registers that it was indicated can be used, that
     955      $   register is dropped.  note that no check is made for live
     956      $   variable.  this check is assumed to have been made previously.
     957
     958      +*  getregpair(r, u1, u2) =   $ get register pair.
     959          call getrpair(u1, u2);
     960          r = gotrpair; **
     961 ..eab
     962
     963
     964      $   -error- macro.
     965
     966      $   this macro is used by -outdata- to print error messages.
     967      $   the first parameter is the error text and the second is the
     968      $   -voa- pointer of the item referred to.
     969
     970      $   first, define error headings.
     971      +*  error_notice  = ' ****error**** ' **
     972      +*  system_notice = '*system error* ' **
     973
     974      +*  error(msg, ptr) =
     975          terml(yes) textl(error_notice) textl(msg)
     976          textl('.  item = ') sdsname(dopsname, vv_naym voa(ptr))
     977          textl(dopsname) endl    terml(no)
     978          errno = errno+1;
     979          **
     980
     981      $   macro -baseprobe-.
     982
     983      $   these macros manipulate the base block.  they will search
     984      $   for an item in the base block and will put it there if it
     985      $   is not already.
     986
     987      $   types for -baseprober-.
     988
     989      +*  rp_normal = 1 **   $ normal search.
     990      +*  rp_addlab = 2 **   $ add to table with no search.
     991      +*  rp_nocomp   =  3 **  $ no compare
     992   +* rp_addbas = rp_addlab **
     993 $ [ds 3 may  addbas renamed addlab from s37 to s11.]
     994
     995      $   define codes for arrays to use for comparisons so that
     996      $   the array need not be passed as a parameter.
     997      +*  ar_val     = 1 **  $ constant value array.
     998      +*  ar_plist   = 2 **  $ parameter array.
    1000
    1001      +*  baseprobe(ptr, hcode, len, type, arrayp, array, arrmx) =
    1002          rparrmx = arrmx;  $ set global.
    1003          call baseprober(rp_normal, ptr, hcode, len, type, arrayp,
    1004              array);   arrmx = rparrmx;  **  $ call and reset global.
    1005
    1006      +*  baseprobelab(ptr, addr) =
    1007          call baseprober(rp_addlab, ptr, 0, 0, addr, 0, 0); **
    1008
    1009      +*  baseprobenc(ptr, len, type, arrayp) =  $ probe no compare
dsi    9          call baseprober(rp_nocomp, ptr, 0, len, type, arrayp ,0); **
    1011
    1012
    1013
    1014      +*  rztok = 12 **
    1015      +*  qstok =  6 **
    1016      +*  sstok = 5 **
    1017      +*  dectok = 4 **  $ integer
    1018      +*  bittok = 8 **  $ bit
    1019      +*  realtok = 14 **  $ real
    1020      +*  strtok = 6 **
    1021
    1022      +*  num_lt = 14 **  $ number of lexical types.
    1023
    1024      +*  szmax = 2048 **  $ maximum size.
    1025
    1026      $   addressing modes
    1027      +*  am_reg  = 0 **  $ ea is register number.
    1028      +*  am_rel  = 1 **  $ ea is offset from index register
    1029      +*  am_mem  = 2 **  $ ea is memory address.
    1030      +*  am_reli = 3 **  $ ea is indirect from offset in register
    1031      +*  num_am  = 3 **  $ number of am modes.
    1032
    1033      $   fields of machine offste
vaxa  80 .+t10.
    1034      +*  mosize = 36  **
    1035      +*  mbo_off = .f. 01, 18, **  $ offset from block
    1036      +*  mbo_blk = .f. 19, 18, **  $ machine block.
vaxa  81 ..t10
vaxa  82 .+t32.
vaxa  83      +*  mosize = 38 **
vaxa  84      +*  mbo_off = .f. 1, 32, **
vaxa  85      +*  mbo_blk = .f. 33, 6, **
vaxa  86 ..t32
    1037
    1038 /*   t10 and dec10 addressing.
    1039
    1040      the am_ codes indicate addressing mode within this asm.
    1041      address designated by triple 
    1042      where mode is one of the am_ modes, mreg is machine register,
    1043      and moff is block and offset.
    1044      mreg must always be specificed, to permit register tracking,
    1045      even if actual register not needed to form address; this pseudo-
    1046      register is the 'spare' register.
    1047      moff consists of two fields, mbo_blk and mbo_blk, where mbo_blk
    1048      is a 'machine block', and mbo_off specifies word offset in block.
    1049      the am modes, and the ea obtained, are as follows:
    1050
    1051      am_reg  ea is register mreg, moff ignored.
    1052      am_rel  ea is offset from index register -  blk+off(mreg)
    1053      am_mem  ea is memory address:  blk+off
    1054      am_reli ea is indirect from offset of register:  @blk+off(mreg)
    1055
    1056      short (1 to 18 bit) constants have am_mem, with mbo_blk of bl_imm
    1057          and bl_off gives constant value.
    1058
    1059      the offset for multiword and array accesses may be negative, so
    1060      that mbo_off and dw_madr may be negative.
    1061       $ [ds 10 may  need to elaborate this]
    1062 */
    1063      $   tmclt maps lexical types to desired conversion action
    1064      +*  tmc_i = 01 **  $ integer
    1065      +*  tmc_b = 02 **  $ bit
    1066      +*  tmc_c = 03 **  $ character (-r- type)
    1067      +*  tmc_r = 04 **  $ real token (not supported in bootstrap).
    1068      +*  tmc_s = 05 **  $ character string (-q- type)
    1069
    1070      +*  num_tmc = 05 **  $ number of tmc codes.
    1071
    1072
    1073      +*  mblkname(i) = mblknames(i) **
       1 .=member start
dsb   12 .+s10  prog start;
dsk   21 .+s32  prog start;
dsb   13 .+s66  subr start;
eaa   45
eaa   46 .+t20.
eaa   47 $    variables for extended addressing (t20).
eaa   48      size  nsheap_opt(ws);  $ nonzero if dynamic heap.
eaa   49      size  nsheap_prm(.sds. filenamelen);
eaa   50      $ nsheap_this is nonzero if current procedure contains
eaa   51      $ to dynamic nameset. in this case nsheap_blk is mba index of the
eaa   52      $ dynamic nameset.
eaa   53      size  nsheap_blk(ws);
eaa   54      size  nsheap_this(1);
eaa   55      size  nsheap_org(.sds. namelen); $ origin for nsheap (extended add
eaa   56      $ we need to consult 'getword' as an oracle to sort out indexed
eaa   57      $ dynamic heap assignments for extended addressing.
eaa   58      $   this is done using the following variables.
eaa   59      size  asmflh_gwi(ps); $ input flag to getword
eaa   60      data  asmflh_gwi = no;
eaa   61      size  asmflh_gwo(ps); $ output from getword
eaa   62      size  asmflh_mreg(ps); $ mreg from getword
eaa   63      size  asmflh_moff(mosize); $ moff from getword
eaa   64      size  asmflh_mode(ws);  $ mode from getword
eaa   65      size  asmflh_varext(ps); $ set if field assignment
eaa   66 ..t20
       3      size  asconstdb(1);         $ drop bit for -asconst-.
       4      size  asconstreal(1);       $ flags real constants for -asconst-.
       5      size  asconstreg(ps);       $ output value from -asconst-.
       6      size  asconstspc(1);        $ 'internal special case in -asconst-'
       7      data  asconstspc = no;
       8      size  asconstsz(ps);        $ size of constant for -asconst-.
       9      size  assignreg(ps);        $ output register from -assignr-.
dsq   59      size  ats_opt(1);       $ on to time stamp generated code
      10      size  baseblockfree(ps);  $ last block in -baseblock- to be free.
      11      size  basefirst(ps);         $ first block in -baseblock- chain.
      12      size  baselast(ps);          $ last block in -baseblock- chain.
      13      size  baselastaddr(mps); $ highest address in -baseblock-.
      14      size  calldropgl(1);        $ '-emitsub- should drop globals'
      15      data  calldropgl = no;
      16      size  callnodrop(1);        $ '-emitsub- should not drop parms'
      17      data  callnodrop = no;
      18      size  codethis(ps);   $ estimated code length.
      19      size  comptime(.sds. lstimelen);  $ time of compilation.
      20      data  comptime = '' .pad. lstimelen;
      21      size  currsubname(.sds. namelen);   $ current subroutine name
      22      size  ddblk(ps);   $ data definition block.
      23      size  ddoff(mps);  $ data definition offset.
      24      $   dd variables used for declaration output.
      25      size  ddlt(ps);          $ lexical type.
      26      size  ddnc(ps);        $ length if character constant.
      27      size  ddnwds(ps);        $ word count.
      28      size  ditemfree(ps);        $ free list for -ditem-.
      29      size  doff(ps);             $ offset for -asmxload- and others.
      30      size  dopcode(ps);          $ operation code at deferring level.
      31      size  dopfbconst(1);        $ 'first bit of extraction constant'
      32      size  dopfbm1(ps);          $ -dreg- for first bit-1.
      33      size  dopfbm1val(ps);       $ value of first bit - 1.
      34      size  dopfree(ps);          $ free head for -dops-.
      35      size  dophasout(1);         $ 'operation has output'
      36      size  dophold(ps);          $ operation to re-issue is deferring.
      37      size  dopindx(ps);          $ index register for .f.
      38      size  dopir(ps);            $ first operand to -dop-.
      39      size  dopjr(ps);            $ second operand to -dop-.
      40      size  dopkr(ps);            $ third operand to -dop-.
      41      size  doplr(ps);        $ fourth operand to -dop-.
      42      size  doplenconst(1);       $ 'length operand of .f. is constant'
      43      size  doplenval(ps);        $ value of length.
      44      size  dopnargs(ps);         $ number of args for -dop-.
      45      size  dopnx(ps);            $ number of extra arguments for -dop-.
      46      size  dopor(ps);            $ output for -dop-.
      47      size  dopname(.sds. 6);  dims dopname(num_do);
      48      data
      49          dopname(do_add) = 'add':
      50          dopname(do_sub) = 'sub':
      51          dopname(do_lt) = 'lt':
      52          dopname(do_ge) = 'ge':
      53          dopname(do_eq) = 'eq':
      54          dopname(do_ne) = 'ne':
      55          dopname(do_mul) = 'mul':
      56          dopname(do_div) = 'div':
      57          dopname(do_and) = 'and':
      58          dopname(do_or) = 'or':
      59          dopname(do_exor) = 'exor':
      60          dopname(do_fcall) = 'fcall':
      61          dopname(do_nb) = 'nb':
      62          dopname(do_not) = 'not':
      63          dopname(do_fb) = 'fb':
      64          dopname(do_scall) = 'scall':
      65          dopname(do_asin) = 'asin':
      66          dopname(do_fasin) = 'fasin':
      67          dopname(do_return) = 'return':
      68          dopname(do_fext) = 'fext':
      69          dopname(do_if) = 'if':
      70          dopname(do_goto) = 'goto':
      71          dopname(do_xload) = 'xload':
      72          dopname(do_xasin) = 'xasin':
      73          dopname(do_xfasin) = 'xfasin':
      74          dopname(do_ifnot) = 'ifnot':
      75          dopname(do_eext) = 'eext':
      76          dopname(do_easin) = 'easin':
      77          dopname(do_xeasin) = 'xeasin':
      78          dopname(do_xsasin) = 'xsasin':
      79          dopname(do_radd) = 'radd':
      80          dopname(do_rsub) = 'rsub':
      81          dopname(do_rlt) = 'rlt':
      82          dopname(do_rge) = 'rge':
      83          dopname(do_req) = 'req':
      84          dopname(do_rne) = 'rne':
      85          dopname(do_rmul) = 'rmul':
      86          dopname(do_rdiv) = 'rdiv':
      87          dopname(do_rusub) = 'rusub':
      88          dopname(do_abs) = 'abs':
dsj   36          dopname(do_float) = 'rfi':
dsj   37          dopname(do_ifix) = 'ifr':
dsj   38          dopname(do_aint) = 'rtr':
dsj   39          dopname(do_amod) = 'rmo':
      89          dopname(do_iabs) = 'iabs':
      90          dopname(do_mod) = 'mod':
      91          dopname(do_sign) = 'sign':
      92          dopname(do_isign) = 'isign':
      93          dopname(do_dim) = 'dim':
      94          dopname(do_idim) = 'idim':
      95          dopname(do_seq) = 'seq':
      96          dopname(do_sne) = 'sne':
      97          dopname(do_goby) = 'goby';
      98      size  dopsname(.sds. namelen);    $ name of routine to call.
      99      size  doptr(ps);            $ pointer to -dops-.
     100      size  dopvar(ps);           $ extractor variable for .f.
     101      size  dopwork(ps);          $ work register for -dop- level.
     102      size  dopxr(ps);            $ extra arguments for -dop-.
     103      dims  dopxr(511);           $ maximum number possible.
     104      size  dregfree(ps);         $ head of -dreg- free list.
     105      size  dropdopflg(1);        $ set for -dropr- to drop -dop-.
     106      data  dropdopflg = no;
     107      size  dwordfree(ps);        $ free list for -dword-.
     108      size  emopparm1(ps), emopparm2(ps);  $ extra parms. to -emopr-.
dst   25 .+enp.
dst   26      nameset nsenp;
dst   27      size enpara(.sds. 30); dims enpara(enpmax);
dst   28      size enptot(ws); data enptot = 0; $ total # of procs
dst   29      size enpopt(1); data enpopt=0;
dst   30      size enpfilename(.sds. filenamelen);
dst   31      size enpnotfound(ws); data enpnotfound = 0;
dst   32      size enpnum(ws); $ number of current procedure
dst   33      size enporg(ws); $ origin for assigned procedure numbers
dst   34      end nameset;
dst   35 ..enp
dsp   27 .+t10  size end_opt(.sds. namelen);  $ end option
     109      size  errno(ps);            $ number of detected errors.
     110      data  errno = 0;
     111      size  exitcode(ps);         $ completion code for -asmexit-.
dsk   22      size  fag_opt(ps);      $ 'functions alter globals'
     112      size  gfoutr(ps);           $ output from -getformr-.
     113      size  gotdreg(ps);          $ return value from -getdregr-.
     114      size  gotreg(ps);           $ return value from -getregr-.
     115      size  gotrpair(ps);         $ return value from -getrpair-.
     116      size  iorc(ws);         $ io return code.
     117      size  isinif(1); data isinif = no;  $ -if- statement flag.
     118      size  isspecial(1);         $ special case flag for -dop- level.
dsq   60 .+t32.
dsq   61    size  iv_opt(ps);         $ option for integer overflow trap.
dsq   62 ..t32
dss   16 .-t32u  +*  lablorg = 0 **
dss   17 .+t32u  size lablorg(ps); data lablorg=0;
     119      size  labluse(ps);          $ last used entry of -lablist-.
     120      size  lcs_opt(1);           $ statistics listing option.
     121      size  loadlab(ps);          $ maximum usage of -lablist- array.
     122      data  loadlab = 0;
     123      size  loadpd(ps);           $ maximum usage of -pdlist- array.
     124      data  loadpd = 0;
     125      size  loadrlab(.sds. namelen);   $ largest user of -lablist-.
     126      data  loadrlab = '';
     127      size  loadrpd(.sds. namelen);   $ largest user of -pdlist-.
     128      data  loadrpd = '';
     129      size  loadrsub(.sds. namelen);   $ largest user of -subname-.
     130      data  loadrsub = '';
     131      size  loadrval(.sds. namelen);    $ routine which used most -val-.
     132      data  loadrval = '';
     133      size  loadsub(ps);          $ maximum usage of -subname- array.
     134      data  loadsub = 0;
     135      size  loadval(ps);          $ maximum usage of -val- array.
     136      data  loadval = 0;
     137      size  nextgfree(ps);        $ next general register free.
dsu   34
dsu   35 $    nsheap_prm gives name of nameset to reference indirectly.
dsu   36 $    if null there is no dynamic indirection.
dsu   37 $    if indirection, nsheap_this is set if the current procedure
dsu   38 $    references the indirect nameset, and nsheap_blk is mba index
dsu   39 $    of the indirect nameset.  nsheapreg_b is register reserved
dsu   40 $    to contain byte address of nameset, nsheapreg_w is register
dsu   41 $    reserved to contain word address.
dsu   42 $    generated code will generally use nsheapreg_w to address the
dsu   43 $    nameset since most instructions have longword context.
dsu   44 $    nsheap_byte is flag set when nsheapreg_b must be used.
dsu   45
dsu   46 .+t32h.
dsu   47      size  nsheap_prm(.sds. filenamelen);
dsu   48      size  nsheap_opt(ws);
dsu   49      size  heapthis(ws); $ nonzero if heap references possible
dsu   50      size  nsheap_blk(ws); $ nonzero if nsheap referenced in curr.
dsu   51      size  nsheap_this(1); $ nonzero if dynamic refs possible
dsu   52      data  nsheap_this = no;
dsu   53      size  nsheap_byte(1); $ nonzero for byte addressing
dsu   54      data  nsheap_byte = no;
dsu   55      size  nsheapreg_w(ps); $ register with head address (word)
dsu   56      size  nsheapreg_b(ps); $ register with heap address (byte address)
dsu   57 ..t32h
dst   36     size nspage_opt(ps);
     138      size  numcalls(ps);         $ number of routine calls.
     139      size  ocs(.sds. 80);  data ocs=''.pad.80;
     140      size  opt_d(1);             $ 'do deferring optimization'
     141      data  opt_d = no;           $ initially don't.
     142      size  opt_f(1);             $ '-if- optimization in effect'
     143      data  opt_f = no;           $ initially not.
     144      size  opt_l(1);             $ 'label optimization in effect'
     145      data  opt_l = no;           $ initially not.
     146      size  putcodei(ps);     $ index for code output.
vaxa  87 .+t32    size  regmask(rhihi);    $ mask of registers used.
     147      size  reguseval(ps);        $ for lru allocation of registers.
     148      size  reissuedop(1);        $ 'issue current -dop- again'
     149      size  returnlab(ps);        $ label for return operation.
     150      size  rparrsz(ws);          $ size for base probe.
     151      size  rparrmx(ws);          $ array maximum for base probe.
     152      size  spcdrop(1);           $ 'special case in -dropr-'
     153      data  spcdrop = no;         $ default is normal.
     154      size  strname(.sds. namelen);  $ for temporary strings.
     155      data  strname = '';
     156      size  subrtype(ps);         $ routine type (subr, fnct, or prog).
     157      $   tmcval is used for constants in target machine form.
     158      size  tmctab(ps);  dims  tmctab(num_lt);
     159      data  tmctab(dectok) = tmc_i:
     160            tmctab(bittok) = tmc_b:
     161            tmctab(strtok) = tmc_s:
     162            tmctab(rztok)  = tmc_c:
     163            tmctab(realtok)= tmc_r;
     164
     165      size  tmcval(mws);  dims tmcval(szmax/mws+1);
     166      size  tmcvalptr(ps);  $ tmcval index.
     167      size  totglobs(ws);         $ total length of globals.
     168      size  totlength(ws);        $ total length of code.
     169      size  totns(ws);            $ total number of namesets.
     170      size  totprocs(ws);         $ total number of proceedures.
     171      data  totglobs = 0:  totlength = 0:
     172            totns = 0: totprocs = 0;
     173      size  trace_a(1);           $ 'trace assembler ops'
     174      size  trace_any(1);         $ set if some trace option is on.
     175      size  trace_c(1);           $ 'trace generated code'
     176      size  trace_d(1);           $ 'trace -dreg-s'
     177      size  trace_l(1);           $ 'trace load cards'
     178      size  trace_o(1);           $ 'trace -dop-s'
     179      size  trace_r(1);           $ 'trace machine registers'
     180      size  trace_v(1);           $ 'trace -voa-'
dsn   28 .+t10    size  univfilename(.sds.filenamelen);  $ universal file name.
dsn   29 .+t10    data  univfilename = '' .pad.filenamelen;
     183      size  voaep(ps);            $ current -voa- pointer.
     184      size  voahead(ps);          $ list of -voa- operations.
     185      size  voalast(ps);          $ last operation in chain.
     186      size  vopcode(ps);          $ -voa- operation code.
     187
     188      $   definitions of tables defined passed by parser.
     189
     190      $   h a .  hashed array.
     191
     192      $   all symbols
     193      $   names, constants and expressions are entered in the ha, and
     194      $   the ha index is main way item is referenced.  the arglist
     195      $   consists largely of ha indices.
     196
     197      $   the fields of the ha are as follows.
     198      $   ep. the index of voa for this item.
     199      $   var. 'is this a variable (ie. not operation) entry'.
     200      $   hainuse. 'is this entry in use'
     201      $   nayme. index in names array if variable name.
     202      $   nchars. number of characters in name or constant.
     203      $   labno. (for names only) lablist index if used as label.
     204      $   namintern. 'is this a compiler generated name'
     205      $   hascon. (for constants only) 'is this safe (short) constant'.
     206      $   zerents. number of preceding empty ha entries (used to
     207      $       pack ha when writing voa file).
     208      $   varluse.  last use in block of variable. (-voa- pointer)
     209      $   tracef. 'is store trace in effect.'
     210      $   chinxf. 'is check index option in effect.'
     211
     212      +*  hasz =  $ size of ha in bits
     213 .+s66   60
dsk   23 .+s32   64
     214 .+s37   64
     215 .+s10    72
     216         **
     218 .+s66    nameset blank;  $ keep in blank common on s66.
dso   12      size  ha(hasz);  dims ha(hadim);
     220 .+s66    end nameset;
     221
     222 .+s66.
     223      +*  ha_ep        = .f. 01, 12, **
     224      +*  ha_hascon    = .f. 13, 01, **
     225      +*  ha_var       = .f. 14, 01, **
     226      +*  ha_hainuse   = .f. 15, 01, **
     227      +*  ha_nayme     = .f. 16, 13, **
     228      +*  ha_labno     = .f. 29, 10, **
     229      +*  ha_tracef    = .f. 39, 01, **
     230      +*  ha_chinxf    = .f. 40, 01, **
     231      +*  ha_namintern = .f. 41, 01, **
     232      +*  ha_zerents   = .f. 42, 11, **
     233      +*  ha_varluse   = .f. 42, 11, **  $ overlays -zerents-
     234      +*  ha_nchars    = .f. 53, 08, **
     235 ..s66
dsk   24 .+s32.
dsk   25      +*  ha_hascon    = .f.  1,  1, **
dsk   26      +*  ha_var       = .f.  2,  1, **
dsk   27      +*  ha_tracef    = .f.  3,  1, **
dsk   28      +*  ha_chinxf    = .f.  4,  1, **
dsk   29      +*  ha_ep        = .f.  5, 11, **
dsk   30      +*  ha_namintern = .f. 16,  1, **
dsk   31      +*  ha_zerents   = .f. 17, 16, **
dsk   32      +*  ha_varluse   = .f. 17, 16, **
dsk   33      +*  ha_nchars    = .f. 33,  8, **
dsk   34      +*  ha_labno     = .f. 41,  9, **
dsk   35      +*  ha_hainuse   = .f. 50,  1, **
dsk   36      +*  ha_nayme     = .f. 54, 11, **
dsk   37 ..s32
     236 .+s37.
     237      +*  ha_hascon    = .f.  1,  1, **
     238      +*  ha_var       = .f.  2,  1, **
     239      +*  ha_tracef    = .f.  3,  1, **
     240      +*  ha_chinxf    = .f.  4,  1, **
     241      +*  ha_ep        = .f.  5, 11, **
     242      +*  ha_namintern = .f. 16,  1, **
     243      +*  ha_zerents   = .f. 17, 16, **
     244      +*  ha_varluse   = .f. 17, 16, **
     245      +*  ha_nchars    = .f. 33,  8, **
     246      +*  ha_labno     = .f. 41,  9, **
     247      +*  ha_hainuse   = .f. 50,  1, **
     248      +*  ha_nayme     = .f. 54, 11, **
     249 ..s37
     250 .+s10.
     251      +*  ha_ep        = .f.  1, 18, **
     252      +*  ha_zerents   = .f. 19, 18, **
     253      +*  ha_varluse   = .f. 19, 18, **
     254      +*  ha_nayme     = .f. 37, 11, **
     255      +*  ha_labno     = .f. 48,  9, **
     256      +*  ha_nchars    = .f. 57,  8, **
     257      +*  ha_hascon    = .f. 65,  1, **
     258      +*  ha_var       = .f. 66,  1, **
     259      +*  ha_tracef    = .f. 67,  1, **
     260      +*  ha_chinxf    = .f. 68,  1, **
     261      +*  ha_namintern = .f. 69,  1, **
     262      +*  ha_hainuse   = .f. 70,  1, **
     263 ..s10
     264
     265      size  ha_0(ps);     $ ha index of constant zero.
     266      size  ha_1(ps);     $ ha index of constant one.
     267
     268
     269      $   m b a .  machine block array
     270      size  mbaptr(ps);  data mbaptr=0;  $ most recent entry in mba
     271
     272      +*  mbasz =  $ size of mba (m-achine b-lock a-rray)
     273 .+s66   60
dsn   30 .+s32   96
dsn   31 .+s37   96
     275 .+s10    72
     276         **
     277
     278      size  mba(mbasz);  dims mba(mbadim);  $ m-achine b-lock a-rray
     279      data  mba = 0(mbadim);
     280
dsb   14 .+s10.
dsb   15      +*  mb_len   = .f.  1, 18, **
dsb   16      +*  mb_org   = .f. 19, 18, **
dsb   17      +*  mb_ha    = .f. 37, 18, **
dsm    9      +*  mb_chain = .f. 55, 11, **
dsm   10      +*  mb_used  = .f. 66,  1, **
dsm   11      +*  mb_def   = .f. 67,  1, **
dsb   21 ..s10
dsk   39 .+s32.
dsk   40      +*  mb_used  = .f.  1,  1, **   $ 'block used in current routine'
dsk   41      +*  mb_def   = .f.  2,  1, **   $ 'block defined in this routine'
dsk   42      +*  mb_ha    = .f.  4, 11, **   $ -ha- index of block name.
dsn   32      +*  mb_len   = .f. 65, 32, **   $ length of block.
dsk   44      +*  mb_org   = .f. 33, 13, **   $ origin address of block.
dsk   45      +*  mb_chain = .f. 46, 11, **   $ -voa- pointer to first var.
dsk   46 ..s32
dsk   47 .+s37.
dsk   48      +*  mb_used  = .f.  1,  1, **   $ 'block used in current routine'
dsk   49      +*  mb_def   = .f.  2,  1, **   $ 'block defined in this routine'
dsk   50      +*  mb_ha    = .f.  4, 11, **   $ -ha- index of block name.
dsn   33      +*  mb_len   = .f. 65, 32, **   $ length of block.
dsk   52      +*  mb_org   = .f. 33, 13, **   $ origin address of block.
dsk   53      +*  mb_chain = .f. 46, 11, **   $ -voa- pointer to first var.
dsk   54 ..s37
     281 .+s66.
     282      +*  mb_len   = .f. 01, 20, **
     283      +*  mb_ha    = .f. 21, 11, **
     284      +*  mb_used  = .f. 32, 01, **
     285      +*  mb_org   = .f. 33, 13, **
     286      +*  mb_def   = .f. 46, 01, **
     287      +*  mb_chain = .f. 47, 11, **
     288 ..s66
     289
     290      size  mbanames(.sds. namelen);
     291      dims  mbanames(mbadim);
     292      data  mbanames(bl_base) = 'bas':
     293            mbanames(bl_const)= 'con':
     294            mbanames(bl_temp) = 'tmp':
dsq   63 .+t32u     mbanames(bl_imm)  = '$':
dsq   64 .+t32v     mbanames(bl_imm)  = '#':
     295            mbanames(bl_local)= 'lcl';
     296
     297      size  mblknames(.sds. namelen);
     298      dims  mblknames(mbadim);
     299      data  mblknames(bl_base) = 'bas':
     300            mblknames(bl_const)= 'con':
     301            mblknames(bl_temp) = 'tmp':
dsq   65 .+t32u     mblknames(bl_imm)  = '$':
dsq   66 .+t32v     mblknames(bl_imm)  = '#':
     302            mblknames(bl_local)= 'lcl';
     303
     304
     305      size  moatab(ws);  dims moatab(num_mo);  $ mop attributes.
     306      data
     307 $                              iw icb ici i
     308          moatab(mo_ban)  =  3b' 1 404 405 1':
     309          moatab(mo_bfb)  =  3b' 5 000 000 1':
     310          moatab(mo_bnb)  =  3b' 5 000 000 0':
     311          moatab(mo_bno)  =  3b' 1 000 000 0':
     312          moatab(mo_bor)  =  3b' 1 434 435 1':
     313          moatab(mo_bxo)  =  3b' 1 430 431 1':
     314          moatab(mo_cal)  =  3b' 3 000 000 0':
     315          moatab(mo_ceq)  =  3b' 1 000 000 1':
     316          moatab(mo_cge)  =  3b' 1 000 000 1':
     317          moatab(mo_cgt)  =  3b' 1 000 000 1':
     318          moatab(mo_cle)  =  3b' 1 000 000 1':
     319          moatab(mo_clt)  =  3b' 1 000 000 1':
     320          moatab(mo_cne)  =  3b' 1 000 000 1':
     321          moatab(mo_iab)  =  3b' 1 000 000 0':
     322          moatab(mo_iad)  =  3b' 1 270 271 1':
     323          moatab(mo_iao)  =  3b' 1 240 000 0':
     324          moatab(mo_ico)  =  3b' 1 210 000 0':
     325          moatab(mo_idi)  =  3b' 3 230 231 1':
     326          moatab(mo_idt)  =  3b' 1 000 000 1':
     327          moatab(mo_ieq)  =  3b' 4 000 000 1':
dsj   40          moatab(mo_ifr)  =  3b' 1 000 000 0':
     328          moatab(mo_ige)  =  3b' 4 000 000 1':
     329          moatab(mo_igt)  =  3b' 4 000 000 1':
     330          moatab(mo_ile)  =  3b' 4 000 000 1':
     331          moatab(mo_ilt)  =  3b' 4 000 000 1':
     332          moatab(mo_imo)  =  3b' 3 000 000 1':
     333          moatab(mo_imt)  =  3b' 1 000 000 1':
     334          moatab(mo_imu)  =  3b' 1 220 221 1':
     335          moatab(mo_ine)  =  3b' 4 000 000 1':
     336          moatab(mo_isi)  =  3b' 4 000 000 1':
     337          moatab(mo_iso)  =  3b' 1 370 000 0':
     338          moatab(mo_isu)  =  3b' 1 274 275 1':
     339          moatab(mo_jeq)  =  3b' 1 000 000 0':
     340          moatab(mo_jge)  =  3b' 1 325 000 0':
     341          moatab(mo_jgt)  =  3b' 1 327 000 0':
     342          moatab(mo_jle)  =  3b' 1 323 000 0':
     343          moatab(mo_jlt)  =  3b' 1 321 000 0':
     344          moatab(mo_jmn)  =  3b' 1 320 000 0':
     345          moatab(mo_jmp)  =  3b' 1 324 000 0':
     346          moatab(mo_jne)  =  3b' 1 326 000 0':
     347          moatab(mo_lda)  =  3b' 1 000 000 0':
     348          moatab(mo_ldf)  =  3b' 1 000 000 0':
     349          moatab(mo_ldl)  =  3b' 1 534 555 0':
     350          moatab(mo_ldr)  =  3b' 2 550 551 0':
     351          moatab(mo_ldw)  =  3b' 1 200 201 1':
eaa   67 .+t20.
eaa   68          moatab(mo_lla)  =  3b' 1 000 000 0':
eaa   69 ..t20
     352          moatab(mo_lpr)  =  3b' 2 000 000 0':
     353          moatab(mo_mvw)  =  3b' 5 000 000 0':
dsu   58 .+t32h.
dsu   59          moatab(mo_mvx)  =  3b' 5 000 000 0':
dsu   60 ..t32h
     354          moatab(mo_rab)  =  3b' 1 000 000 0':
     355          moatab(mo_rad)  =  3b' 1 140 000 1':
     356          moatab(mo_rco)  =  3b' 1 210 000 0':
     357          moatab(mo_rdi)  =  3b' 2 170 000 1':
     358          moatab(mo_req)  =  3b' 4 000 000 1':
     359          moatab(mo_ret)  =  3b' 3 000 000 0':
dsj   41          moatab(mo_rfi)  =  3b' 1 000 000 1':
     360          moatab(mo_rge)  =  3b' 4 000 000 1':
     361          moatab(mo_rgt)  =  3b' 4 000 000 1':
     362          moatab(mo_rle)  =  3b' 4 000 000 1':
     363          moatab(mo_rlt)  =  3b' 4 000 000 1':
     364          moatab(mo_rmo)  =  3b' 3 000 000 1':
     365          moatab(mo_rmu)  =  3b' 1 160 000 1':
     366          moatab(mo_rne)  =  3b' 4 000 000 1':
     367          moatab(mo_rsi)  =  3b' 1 000 000 1':
     368          moatab(mo_rsu)  =  3b' 1 150 000 1':
dsj   42          moatab(mo_rtr)  =  3b' 1 000 000 0':
     369          moatab(mo_spr)  =  3b' 2 000 000 0':
     370          moatab(mo_stf)  =  3b' 1 000 000 0':
     371          moatab(mo_stl)  =  3b' 1 506 000 0':
     372          moatab(mo_str)  =  3b' 1 542 000 0':
     373          moatab(mo_stw)  =  3b' 1 202 000 0':
     374          moatab(mo_zeb)  =  3b' 4 251 000 1':
eaa   70 .+t20.
eaa   71          moatab(mo_hba)  =  3b' 1 000 000 1':
eaa   72          moatab(mo_hbb)  =  3b' 1 000 000 1':
eaa   73          moatab(mo_hbc)  =  3b' 1 000 000 1':
eaa   74 ..t20
     375          moatab(mo_zew)  =  3b' 1 400 000 0';
     376
     377      size  names(ws); dims names(namesdim);  $ -names- array space.
     378
     379
     380
     381      size  val(ws);  dims val(valdim);    $ -val- array space.
     382      size  valptr(ps);                    $ last index in -val-.
     383
     384      +*  voafnct = 1 **
     385      size  voaptr(ps);       $ pointer to last used item in -voa-.
     386
     387      +*  voasz = $ size of voa entry.
     388 .+s10    144
dsn   34 .+s32    192
dsn   35 .+s37    192
     390 .+s66    120
     391          **
     392 .+s66    nameset blank;
     393      size  voa(voasz);  dims voa(voadim);
     394 .+s66    end nameset;
     395
     396      size  voawrt(1);  $ on if writing voa file
     397      $   v o a   f i e l d s
     398
     399      $   fields common to both -operation- and -quantity- operations
     400
     401 .+s66.
     402      +*  vv_deflev = .f. 1, 6, **   $ definition level
     403      +*  vv_keeb = .f. 7, 1, **  $ keep bit for holding till blkend
     404      +*  vv_naym = .f. 8, 10, **  $ ha ptr
     405      +*  vv_opb = .f. 18, 1, **  $ 'is this an operation'
     406      +*  vv_syze = .f. 19, 11, **  $ entry size in bits
     407      +*  vv_amode = .f. 118, 1, **    $ real or integer mode
     408
     409      $   voa field for -variable' or non-operation entries (opb = no)
     410
     411      +*  vv_arb = .f. 30, 1, **     $ argument bit
     412      +*  vv_argno = .f. 31, 5, **   $  argument no of parameter
     413      +*  vv_const = .f. 36, 1, **   $ on if 'constant'
     414      +*  vv_dimn = .f. 37, 16, **   $ dimension of array (or 0 if no di
     415      +*  vv_vlen = .f. 55, 5, **    $ no of words in constant value
     416      +*  vv_temb = .f. 60, 1, **    $ on if 'temporary'
     417      +*  vv_voanl = .f. 61, 9, **  $ pointer to -nl- for global
     418      +*  vv_madr = .f. 70, 16, **   $ machine address of item
     419      +*  vv_mblk = .f. 86, 6, **    $ machine block of item
     420      +*  vv_type = .f. 92, 2, **    $ quantity type
     421      +*  vv_vbeg = .f. 94, 12, **   $ start of const val in -val- array
     422      +*  vv_signbit = .f.106,1, **  $ sign of constant (0=+, 1=-)
     423      +*  vv_lextype = .f. 107,5, **  $ lexical type of constant
     424      +*  vv_isafnct = .f. 113,1, **  $ set when name used as function n
     425      +*  vv_varnuse = .f. 114, 4, **  $ number of uses of var.
     426      +*  vv_varnusemax = 1b'1111' **  $ max of -varnuse- field
     427      +*  vv_isavar = .f. 119, 1, **   $ 'used as variable'
     428      +*  vv_frsdata = .f.  121, 11, **  $ pointer to first data op.
     429      +*  vv_ppdata  = .f.  53, 1, **  $ possible permanent value
     430      +*  vv_inreg   = .f.  61, 8, **  $ -dreg- containing item.
     431
     432      $   fields for operation type entries
     433
     434
     435      +*  vv_argbeg = .f. 30, 9, **  $ beginning of extra arguments
     436      +*  vv_arglen = .f. 39,  9, **   $ number of extra arguments
     437      +*  vv_db1 = .f. 49, 1, **     $ drop bit for input 1
     438      +*  vv_db2 = .f. 50, 1, **     $ drop bit for input 2
     439      +*  vv_db3 = .f. 51, 1, **     $ drop bit for input 3
     440      +*  vv_opcode = .f. 52, 7, **
     441      +*  vv_seblk = .f. 59, 1, **  $ indicates if scall ends block
     442      +*  vv_bytaln = .f. 60, 1, **  $ indicates char. extract or assign
     443      +*  vv_inp1 = .f. 61, 12, **   $ voa index of first input
     444      +*  vv_inp2 = .f. 73, 12, **   $ voa index of second input
     445      +*  vv_inp3 = .f. 85, 12, **   $ voa index of third input
     446      +*  vv_oup = .f. 97, 12, **    $ voa index of output
     447      +*  vv_lastuse = .f. 109, 9, **$ voa index of last use of op
     448      +*  vv_dboup = .e. 119, 01, ** $ drop bit if oup used as input.
     449 ..s66
     450
dsk   56 .+s32.
dsk   57      +*  vv_amode   = .f.   1,  1, **  $ arithmetic mode.
dsk   58      +*  vv_keeb    = .f.   2,  1, **  $ '-deflev- overflow'
dsk   59      +*  vv_opb     = .f.   3,  1, **  $ 'operation entry'
dsk   60      +*  vv_naym    = .f.   4, 10, **  $ -ha- index.
dsk   61      +*  vv_syze    = .f.  17, 16, **  $ size of item in bits.
dsk   62      +*  vv_deflev  = .f.  33,  6, **  $ definition level.
dsk   63
dsk   64      $   fields for variable operand entries.
dsk   65
dsk   66      +*  vv_const   = .f.  14,  1, **  $ 'operand is constant'
dsk   67      +*  vv_temb    = .f.  15,  1, **  $ 'operand is temporary'
dsk   68      +*  vv_signbit = .f.  16,  1, **  $ sign bit.
dsk   69      +*  vv_isafnct = .f.  39,  1, **  $ 'operand used as function'
dsk   70      +*  vv_inreg   = .f.  40,  8, **  $ -dreg- containing item.
dsk   71      +*  vv_ppdata  = .f.  48,  1, **  $ 'possible permanent value'
dsn   36      +*  vv_dimn    = .f.  129, 32, **  $ dimension of array.
dsk   73      +*  vv_varnuse = .f.  65,  8, **  $ number of uses.
dsk   74      +*  vv_mblk    = .f.  73,  7, **  $ machine block number.
dsn   37      +*  vv_madr    = .f.  161, 32, **  $ machine address.
dsk   76      +*  vv_frsdata = .f.  97, 12, **  $ pointer to first -data- op.
dsk   77      +*  vv_vlen    = .f.  97,  8, **  $ length in -val- array.
dsk   78      +*  vv_lextype = .f. 105,  4, **  $ lexical type.
dsk   79      +*  vv_argno   = .f. 109,  5, **  $ argument number.
dsk   80      +*  vv_arb     = .f. 114,  1, **  $ 'operand is routine argument'
dsk   81      +*  vv_type    = .f. 115,  2, **  $ operand type.
dsk   82      +*  vv_vbeg    = .f. 117, 12, **  $ -val- pointer for constannts.
dsk   83
dsk   84      $   fields for operation entries.
dsk   85
dsk   86      +*  vv_db1     = .f.  14,  1, **  $ 'last use of first operand'
dsk   87      +*  vv_db2     = .f.  15,  1, **  $ 'last use of second operand'
dsk   88      +*  vv_db3     = .f.  16,  1, **  $ 'last use of third operand'
dsk   89      +*  vv_chain   = .f.  17, 16, **  $ operation chain.
dsk   90      +*  vv_arglen  = .f.  39,  9, **  $ length of -xarg- entries.
dsk   91      +*  vv_dboup   = .f.  48,  1, **  $ 'last use of output'
dsk   92      +*  vv_inp1    = .f.  49, 16, **  $ first input.
dsk   93      +*  vv_inp2    = .f.  65, 11, **  $ second input.
dsk   94      +*  vv_lastuse = .f.  76, 10, **  $ last use pointer.
dsk   95      +*  vv_inp3    = .f.  86, 11, **  $ third input.
dsk   96      +*  vv_opcode  = .f.  97,  8, **  $ operation code.
dsk   97      +*  vv_seblk   = .f. 105,  1, **  $ 'call ends block'
dsk   98      +*  vv_bytaln  = .f. 106,  1, **  $ 'byte aligned'
dsk   99      +*  vv_argbeg  = .f. 107, 10, **  $ -xarg- pointer.
dsk  100      +*  vv_oup     = .f. 118, 11, **  $ output.
dsk  101 ..s32
dsk  102 .+s37.
dsk  103      +*  vv_amode   = .f.   1,  1, **  $ arithmetic mode.
dsk  104      +*  vv_keeb    = .f.   2,  1, **  $ '-deflev- overflow'
dsk  105      +*  vv_opb     = .f.   3,  1, **  $ 'operation entry'
dsk  106      +*  vv_naym    = .f.   4, 10, **  $ -ha- index.
dsk  107      +*  vv_syze    = .f.  17, 16, **  $ size of item in bits.
dsk  108      +*  vv_deflev  = .f.  33,  6, **  $ definition level.
dsk  109
dsk  110      $   fields for variable operand entries.
dsk  111
dsk  112      +*  vv_const   = .f.  14,  1, **  $ 'operand is constant'
dsk  113      +*  vv_temb    = .f.  15,  1, **  $ 'operand is temporary'
dsk  114      +*  vv_signbit = .f.  16,  1, **  $ sign bit.
dsk  115      +*  vv_isafnct = .f.  39,  1, **  $ 'operand used as function'
dsk  116      +*  vv_inreg   = .f.  40,  8, **  $ -dreg- containing item.
dsk  117      +*  vv_ppdata  = .f.  48,  1, **  $ 'possible permanent value'
dsn   38      +*  vv_dimn    = .f.  129, 32, **  $ dimension of array.
dsm   12      +*  vv_varnuse = .f.  65,  8, **  $ number of uses.
dsm   13      +*  vv_mblk    = .f.  73,  7, **  $ machine block number.
dsn   39      +*  vv_madr    = .f.  161, 32, **  $ machine address.
dsm   15      +*  vv_frsdata = .f.  97, 12, **  $ pointer to first -data- op.
dsm   16      +*  vv_vlen    = .f.  97,  8, **  $ length in -val- array.
dsm   17      +*  vv_lextype = .f. 105,  4, **  $ lexical type.
dsm   18      +*  vv_argno   = .f. 109,  5, **  $ argument number.
dsm   19      +*  vv_arb     = .f. 114,  1, **  $ 'operand is routine argument'
dsm   20      +*  vv_type    = .f. 115,  2, **  $ operand type.
dsm   21      +*  vv_vbeg    = .f. 117, 12, **  $ -val- pointer for constannts.
dsk  129
dsk  130      $   fields for operation entries.
dsk  131
dsk  132      +*  vv_db1     = .f.  14,  1, **  $ 'last use of first operand'
dsk  133      +*  vv_db2     = .f.  15,  1, **  $ 'last use of second operand'
dsk  134      +*  vv_db3     = .f.  16,  1, **  $ 'last use of third operand'
dsk  135      +*  vv_chain   = .f.  17, 16, **  $ operation chain.
dsk  136      +*  vv_arglen  = .f.  39,  9, **  $ length of -xarg- entries.
dsk  137      +*  vv_dboup   = .f.  48,  1, **  $ 'last use of output'
dsk  138      +*  vv_inp1    = .f.  49, 16, **  $ first input.
dsk  139      +*  vv_inp2    = .f.  65, 11, **  $ second input.
dsk  140      +*  vv_lastuse = .f.  76, 10, **  $ last use pointer.
dsk  141      +*  vv_inp3    = .f.  86, 11, **  $ third input.
dsk  142      +*  vv_opcode  = .f.  97,  8, **  $ operation code.
dsk  143      +*  vv_seblk   = .f. 105,  1, **  $ 'call ends block'
dsk  144      +*  vv_bytaln  = .f. 106,  1, **  $ 'byte aligned'
dsk  145      +*  vv_argbeg  = .f. 107, 10, **  $ -xarg- pointer.
dsk  146      +*  vv_oup     = .f. 118, 11, **  $ output.
dsk  147 ..s37
     451 .+s37.
     452      +*  vv_amode   = .f.   1,  1, **
     453      +*  vv_keeb    = .f.   2,  1, **
     454      +*  vv_opb     = .f.   3,  1, **
     455      +*  vv_naym    = .f.   4, 10, **
     456      +*  vv_syze    = .f.  17, 16, **
     457      +*  vv_deflev  = .f.  33,  6, **
     458
     459      +*  vv_const   = .f.  14,  1, **
     460      +*  vv_temb    = .f.  15,  1, **
     461      +*  vv_signbit = .f.  16,  1, **
     462      +*  vv_isafnct = .f.  39,  1, **
     463      +*  vv_voanl   = .f.  40,  9, **
     464      +*  vv_dimn    = .f.  49, 16, **
     465      +*  vv_type    = .f.  65,  2, **
     466      +*  vv_vbeg    = .f.  67, 12, **
     467      +*  vv_lextype = .f.  79,  5, **
     468      +*  vv_arb     = .f.  84,  1, **
     469      +*  vv_isavar  = .f.  85,  1, **
     470      +*  vv_vlen    = .f.  89,  8, **
     471      +*  vv_madr    = .f.  97, 16, **
     472      +*  vv_mblk    = .f. 113,  8, **
     473      +*  vv_varnuse = .f. 121,  8, **
     474      +*  vv_varnusemax = 4b'ff' **
     475
     476      +*  vv_db1     = .f.  14,  1, **
     477      +*  vv_db2     = .f.  15,  1, **
     478      +*  vv_db3     = .f.  16,  1, **
     479      +*  vv_arglen  = .f.  39,  9, **
     480      +*  vv_dboup   = .f.  48,  1, **
     481      +*  vv_inp1    = .f.  49, 16, **
     482      +*  vv_inp2    = .f.  65, 11, **
     483      +*  vv_lastuse = .f.  76, 10, **
     484      +*  vv_inp3    = .f.  86, 11, **
     485      +*  vv_opcode  = .f.  97,  8, **
     486      +*  vv_seblk   = .f. 105,  1, **
     487      +*  vv_bytaln  = .f. 106,  1, **
     488      +*  vv_argbeg  = .f. 107, 10, **
     489      +*  vv_oup     = .f. 118, 11, **
     490 ..s37
dsb   22 .+s10.
dsb   23      +*  vv_amode   = .f.   1,  1, **
dsb   24      +*  vv_keeb    = .f.   2,  1, **
dsb   25      +*  vv_opb     = .f.   3,  1, **
dsb   26      +*  vv_naym    = .f.   4, 10, **
dsb   27      +*  vv_syze    = .f.  17, 11, **
dsb   28      +*  vv_deflev  = .f.  28,  6, **
dsb   29
dsb   30      +*  vv_const   = .f.  14,  1, **
dsb   31      +*  vv_temb    = .f.  15,  1, **
dsb   32      +*  vv_signbit = .f.  16,  1, **
dsb   33      +*  vv_isafnct = .f.  37,  1, **
dsb   34      +*  vv_inreg   = .f.  38,  8, **
dsb   35      +*  vv_ppdata  = .f.  46,  1, **
dsb   36      +*  vv_voanl   = .f.  38,  9, **
dsb   37      +*  vv_vlen    = .f.  47,  8, **
dsb   38      +*  vv_lextype = .f.  55,  4, **
dsb   39      +*  vv_frsdata = .f.  47, 12, **
dsb   40      +*  vv_argno   = .f.  59,  5, **
dsb   41      +*  vv_mblk    = .f.  64,  6, **
dsb   42      +*  vv_arb     = .f.  70,  1, **
dsb   43      +*  vv_isavar  = .f.  71,  1, **
dsb   44      +*  vv_type    = .f.  73,  2, **
dsn   40      +*  vv_dimn    = .f.  75, 17, **
dsn   41      +*  vv_madr    = .f.  92, 17, **
dsm   22      +*  vv_vbeg    = .f. 109, 12, **
dsm   23      +*  vv_varnuse = .f. 121,  8, **
dsb   49      +*  varnusemax = 4b'ff' **
dsb   50
dsb   51      +*  vv_db1     = .f.  14,  1, **
dsb   52      +*  vv_db2     = .f.  15,  1, **
dsb   53      +*  vv_db3     = .f.  16,  1, **
dsb   54      +*  vv_arglen  = .f.  37,  9, **
dsb   55      +*  vv_dboup   = .f.  46,  1, **
dsb   56      +*  vv_inp1    = .f.  47, 11, **
dsb   57      +*  vv_inp2    = .f.  58, 11, **
dsb   58      +*  vv_seblk   = .f.  69,  1, **
dsb   59      +*  vv_bytaln  = .f.  70,  1, **
dsb   60      +*  vv_inp3    = .f.  73, 11, **
dsb   61      +*  vv_lastuse = .f.  84, 10, **
dsb   62      +*  vv_oup     = .f.  94, 11, **
dsb   63      +*  vv_opcode  = .f. 109,  7, **
dsb   64      +*  vv_argbeg  = .f. 116, 10, **
dsb   65 ..s10
     532
     533      +*  vv_chain = vv_syze **   $ used for operations.
     534
     535      $   to keep voa at two words for s66 bootstrap, the vv field
     536      $   vv_frsdata is kept in separate array.
     537      $   the conditional symbol vvfrs is on for separate frsdata.
     538 .+s10.
     539 .-set vvfrs
     540 ..s10
     541 .+s66.
     542 .+set vvfrs
     543 ..s66
     544 .+vvfrs.
     545      +*  vv_frsdata = **   $ drop prior definition
     546      +*  vvfrsdata(i) =
     547          .f. 1 + 16*((i) - 4*((i)/4)), 12, frsdataara(1+(i)/4) **
     548      size  frsdataara(ws);  dims frsdataara((voadim)/4+2);
     549 ..vvfrs
     550      size  voafilename(ws);  $ name of voa file
     551      $   v o a   f i l e   m a c r o s
     552
     553      +*  vf_level = .e. 17, 16, **  $ julian date of last change
     554          $ relative to 1 jan 1976 (ie, juliandate - 76000).
     555      $   *** when change array size or fields, update version no. ***
     556
     557      $   codes for items in voa-file
     558      +*  vh_eof = 0 ** $ marks end of file
     559      +*  vh_hdr = 1 ** $ file header code
     560      +*  vh_asm = 2 ** $ routine header code
     561      +*  vh_voa =    3 ** $ voa
     562      +*  vh_ha =    4** $ ha
     563      +*  vh_names =  5 ** $ names array
     564      +*  vh_xarg =   6 ** $ xarg array
     565      +*  vh_val  =  7 ** $ val array
     566      +*  vh_mba = 8 **  $ m-achine b-lock a-rray (mba)
     567      +*  vh_eos = 9 **  $ code for end of subprogram
     568
     569      +*  num_vh = 9 **
     570
dsk  148 .+s32.
dsk  149      $   first, fields common to all header entries
dsk  150      +*  vf_code = .e. 1,16, **  $  code of item
dsk  151      +*  vf_lo   = .e.49,16, **  $ lo entry of array
dsk  152      $   for debugging
dsk  153      +*  vf_hi = .e.65,16, **  $ high entry of array
dsk  154      +*  vf_listcode = .e. 81, 01, **  $ on to list generated code.
dsk  155          $ to format of any item written to voa.
dsk  156      +*  vf_hamax = .e. 97,16, **  $ hamax in gen
dsk  157      $   bits  113...128 reserved for future expansion
dsk  158
dsk  159      $   fields used to pass non/array args to assembler
dsk  160      +*  vf_asmarg = .e. 129, 16,**  $ assemblarg
dsk  161      +*  vf_init = .e. 145, 16,**  $ init
dsk  162      +*  vf_lablistptr = .e. 161, 16, **  $  lablistptr
dsk  163      +*  vf_sub1 = .e. 177, 16, **  $ subinfo(1), a name
dsk  164      +*  vf_sub2 = .e. 193, 16,  **  $ subinfo(2)
dsk  165      +*  vf_sub3 = .e. 209, 16, **  $ subinfo(3)
dsk  166      +*  vf_subrargs = .e. 225, 16, ** $ no. of arguments of current
dsk  167      $   routine
dsk  168      +*  vf_ha0  = .e. 241, 16, ** $ ha index of constant 0.
dsk  169      +*  vf_ha1  = .e. 257, 16, ** $ ha index of constant 1.
dsk  170 ..s32
     571 .+s37.
     572      $   first, fields common to all header entries
     573      +*  vf_code = .e. 1,16, **  $  code of item
     574      +*  vf_lo   = .e.49,16, **  $ lo entry of array
     575      $   for debugging
     576      +*  vf_hi = .e.65,16, **  $ high entry of array
     577      +*  vf_listcode = .e. 81, 01, **  $ on to list generated code.
     578          $ to format of any item written to voa.
     579      +*  vf_hamax = .e. 97,16, **  $ hamax in gen
     580      $   bits  113...128 reserved for future expansion
     581
     582      $   fields used to pass non/array args to assembler
     583      +*  vf_asmarg = .e. 129, 16,**  $ assemblarg
     584      +*  vf_init = .e. 145, 16,**  $ init
     585      +*  vf_lablistptr = .e. 161, 16, **  $  lablistptr
     586      +*  vf_sub1 = .e. 177, 16, **  $ subinfo(1), a name
     587      +*  vf_sub2 = .e. 193, 16,  **  $ subinfo(2)
     588      +*  vf_sub3 = .e. 209, 16, **  $ subinfo(3)
     589      +*  vf_subrargs = .e. 225, 16, ** $ no. of arguments of current
     590      $   routine
     591      +*  vf_ha0  = .e. 241, 16, ** $ ha index of constant 0.
     592      +*  vf_ha1  = .e. 257, 16, ** $ ha index of constant 1.
     593 ..s37
     594 .+s66.
     595      +*  vf_code = .e. 01, 06, **  $  code of item
     596      +*  vf_hdrseq = .e. 07, 18, **  $ header sequence number.
     597      +*  vf_es   = .e. 25, 12, **  $  entry size in bits
     598      +*  vf_lo   = .e. 37, 12, **  $ lo entry of array
     599      +*  vf_hi = .e. 49, 12, **  $ high entry of array
     600      +*  vf_listcode = .e. 61, 01, **  $ on to list generated code.
     601      +*  vf_hamax = .e. 62, 11, **  $ hamax in gen
     602      +*  vf_asmarg = .e. 73, 12,**  $ assemblarg
     603      +*  vf_init = .e. 85, 12,**  $ init
     604      +*  vf_lablistptr = .e. 97, 12, **  $  lablistptr
     605      +*  vf_sub1 = .e. 109, 12, **  $ subinfo(1), a name
     606      +*  vf_sub2 = .e. 121, 12,  **  $ subinfo(2)
     607      +*  vf_sub3 = .e. 133, 12, **  $ subinfo(3)
     608      +*  vf_subrargs = .e. 145, 12, ** $ no. of arguments of current
     609      $   routine
     610      +*  vf_ha0  = .e. 157, 12, ** $ ha index of constant 0.
     611      +*  vf_ha1  = .e. 169, 12, ** $ ha index of constant 1.
     612 ..s66
     613 .+s10.
     614      +*  vf_code = .f. 1, 18, **
     615      +*  vf_hdrseq = .f. 19, 18, **
     616      +*  vf_es = .f. 37, 18, **
     617      +*  vf_lo = .f. 55, 18, **
     618      +*  vf_hi = .f. 73, 18, **
     619      +*  vf_listcode = .f. 91, 1, **
     620      +*  vf_hamax = .f. 109, 18, **
     621      +*  vf_asmarg = .f. 127, 18, **
     622      +*  vf_init = .f. 145, 18, **
     623      +*  vf_lablistptr = .f. 163, 18, **
     624      +*  vf_sub1 = .f. 181, 18, **
     625      +*  vf_sub2 = .f. 199, 18, **
     626      +*  vf_sub3 = .f. 217, 18, **
     627      +*  vf_subrargs = .f. 235, 18, **
     628      +*  vf_ha0 = .f. 253, 18, **
     629      +*  vf_ha1 = .f. 271, 18, **
     630 ..s10
     631
     632      +*  vf_lablistp = vf_lablistptr **  $ rename with edit later.
     633
     634      $   values for routine type.
     635
     636      +*  st_subr = 0 **  $ subroutine.
     637      +*  st_fnct = 1 **  $ function.
     638      +*  st_prog = 2 **  $ main program.
     639
     640      +*  vofsz =  $ size of voa header frame
     641 .+s10    288
dsk  171 .+s32    256
dsk  172 .+s37    256
     642 .+s66    240
     643          **
     644
     645      size  vof(vofsz);  $ -voa- header frame.
     646
     647
     648
     649      $   x a r g.  extra arguments array
dsn   42      +*  xargsz =  $ size of xarg array.
dsn   43 .+s10    ws
dsn   44 .+s32    64
dsn   45 .+s37    64
dsn   46 .+s66    ws
dsn   47          **
     651      +*  xargmax = 511 **  $ xarg dims
     652 .+s66    nameset blank;  $ keep in blank common on s66.
     653      size  xarg(xargsz); dims xarg(xargmax);  $ extra arguments array
     654 .+s66    end nameset;
     655      size  xargptr(ps);  data xargptr = 1;   $ ptr to xarg
     656      $   fields of xarg array
     657      $   xa_dbf is called xa_db.
     658 .+s66.
     659      +*  xa_voa = .f. 16, 15, **        $ ptr to voa entry
     660      +*  xa_db= .f. 31, 1, **
     661      +*  xa_rep = .f. 1, 15, **
     662 ..s66
dsk  173 .+s32.
dsk  174      +*  xa_voa = .f.  1, 16, **
dsk  175      +*  xa_db = .f. 17,  1, **
dsn   48      +*  xa_rep = .f. 33, 32, **
dsk  177 ..s32
     663 .+s37.
     664      +*  xa_voa = .f.  1, 16, **
     665      +*  xa_db = .f. 17,  1, **
dsn   49      +*  xa_rep = .f. 33, 32, **
     667 ..s37
     668 .+s10.
dsn   50      +*  xa_voa = .f.  1, 15, **
dsn   51      +*  xa_rep = .f. 19, 18, **
dsn   52      +*  xa_db = .f. 16,  1, **
     672 ..s10
     673
     674      +*  xa_arf = xa_voa **  $ rename with edit later.
     675 .+defer.
     676      $   -dops-
     677
     678      $   the -dops- array is used if deferring is set to hold
     679      $   operations that have been deferred until a later time.  these
     680      $   operations are linked via the -dr_out- field of the dummy
     681      $   register which is the output of an operation.
     682
     683      $   fields in -dops-.
     684
     685      +*  dp_inp1  = .f. 01, 8, **  $ first input.
     686      +*  dp_inp2  = .f. 09, 8, **  $ second input.
     687      +*  dp_inp3  = .f. 17, 8, **  $ third input.
     688      +*  dp_oup   = .f. 25, 8, **  $ output.
     689 .+s10   +*  dp_op  =  .f. 57, 8, **  $ operation code
dsk  178 .+s32    +*  dp_op  = .f. 33, 8, **  $ operation code
dsk  179 .+s37    +*  dp_op  = .f. 33, 8, **  $ operation code
     690 .+s66   +*  dp_op  =  .f. 33, 8, **  $ operation code
     691      +*  dp_chain = .f. 41, 8, **  $ points to next free entry.
     692      +*  dp_nargs = .f. 49, 8, **  $ number of arguments (0,1,2, or 3)
     693
     694      +*  dopssz = $ size of dops
     695 .+s10    72
dsk  180 .+s32    64
dsk  181 .+s37    64
     696 .+s66    60
     697          **
     698
     699      size  dops(dopssz); dims dops(dopsdim);
     700
     701 ..defer
     702
     703      $   operands in the code generator are passed as dummy registers.
     704      $   these dummy registers point to dummy words and dummy items.
     705      $   a dummy item is, in a sense, a local copy of the -voa- entry
     706      $   for that variable (if it is a variable).  there is one dummy
     707      $   word for each word of an item that has been used and there
     708      $   may be many dummy registers for each word.  one dummy register
     709      $   for each word.
     710
     711      $   the dummy items, words, and, registers and chained and link
     712      $   to and from each other.  the information contained in each
     713      $   block is that information which is common for all blocks
     714      $   under it.
     715
     716      $   fields of -ditem-.
     717
     718 /*
     719      di_chain is pointer to voa if di_baseblk is zero, or to voa
     720          if di_baseblk is nonzer.
     721      di_syze is item size.
     722      di_scon is on if item is short constant (1 to 18 bits), in which
     723          case di_cval is constant value.
     724      di_nwords is number of machine words in item.
     725      di_count is number of users of item.
     726      di_addrreg is nonzero if address of item is in machine reg addrreg
     727      di_out is deferred output ptr for dop.
     728      di_luse is number of drops.
     729      di_lword is start of -dword- chain.
     730      di_mblk is machine block for item.
     731      di_scon is nonzero if item is short constant, in which case
     732          di_cval contains constant value.
     733      di_mw is nonzero for multi-word item.
     734      di_real is nonzero for real, or floating point, item.
     735      di_baseblk is nonzero if di_chain points to baseblock, not voa.
     736      di_array is nonzero if item is array.
     737      di_temp is nonzero if item is temporary.
     738      di_const is nonzero if item is constant.
     739      di_var is nonzero if item is variable.
     740      di_ldrop is nonzero if last use in voa.
     741      di_anum is nonzero if item if procedure argument, and value gives
     742          argument number.
     743 */
     744
     745      +*  di_luseminus1val = 4b'ff' ** $ to avoid overflow problem.
dsb   66 .+s10.
rkb   13      +*  scs = 18 **  $ short constant size.
dsb   67      +*  di_chain   = .f.  01, 12, **
dsb   68      +*  di_syze    = .f.  13, 11, **
dsb   69      +*  di_cval    = .f. 127, 18, **
dsb   70      +*  di_nwords  = .f.  42, 08, **
dsb   71      +*  di_count   = .f.  50, 08, **
dsb   72      +*  di_addrreg = .f.  61, 05, **
dsb   73      +*  di_out     = .f. 118, 08, **
dsb   74      +*  di_luse    = .f.  76, 08, **
dsb   75      +*  di_lword   = .f.  84, 08, **
dsb   76      +*  di_mblk    = .f.  92, 08, **
dsb   77      +*  di_scon    = .f. 100, 01, **
dsb   78      +*  di_mw      = .f. 101, 01, **
dsb   79      +*  di_real    = .f. 102, 01, **
dsb   80      +*  di_baseblk = .f. 103, 01, **
dsb   81      +*  di_array   = .f. 104, 01, **
dsb   82      +*  di_temp    = .f. 105, 01, **
dsb   83      +*  di_const   = .f. 106, 01, **
dsb   84      +*  di_var     = .f. 107, 01, **
dsb   85      +*  di_ldrop   = .f. 109, 01, **
dsb   86      +*  di_anum    = .f. 110, 08, **
dsb   87 ..s10
dsk  182 .+s32.
rkb   14      +*  scs = 16 **  $ short constant size.
dsk  183      +*  di_chain   = .f.   1, 16, **  $ ptr to -voa- or -baseblock-.
dsk  184      +*  di_syze    = .f.  17, 16, **  $ length in bits of item.
dsk  185      +*  di_cval    = .f.  33, 16, **  $ short constant value.
dsk  186      +*  di_nwords  = .f.  49,  8, **  $ number of words in item.
dsk  187      +*  di_count   = .f.  57,  8, **  $ number of users of item.
dsk  188      +*  di_addrreg = .f.  65,  8, **  $ address register for item.
dsk  189      +*  di_out     = .f.  73,  8, **  $ deferred output of -dop-.
dsk  190      +*  di_luse    = .f.  81,  8, **  $ number of drops.
dsk  191      +*  di_lword   = .f.  89,  8, **  $ head of -dword- chain.
dsk  192      +*  di_mblk    = .f.  97,  8, **  $ machine block of item.
dsk  193      +*  di_scon    = .f. 105,  1, **  $ 'item is short constant'
dsk  194      +*  di_mw      = .f. 106,  1, **  $ 'item is multi-word'
dsk  195      +*  di_real    = .f. 107,  1, **  $ 'item is floating-point'
dsk  196      +*  di_baseblk = .f. 108,  1, **  $ 'item is in base block'
dsk  197      +*  di_array   = .f. 109,  1, **  $ 'item is array'
dsk  198      +*  di_temp    = .f. 111,  1, **  $ 'item is temporary'
dsk  199      +*  di_const   = .f. 112,  1, **  $ 'item is constant'
dsk  200      +*  di_var     = .f. 113,  1, **  $ 'item is variable'
dsk  201      +*  di_ldrop   = .f. 115,  1, **  $ 'last use in -voa-'
dsk  202      +*  di_anum    = .f. 121,  8, **  $ argument number.
dsk  203 ..s32
dsk  204 .+s37.
rkb   15      +*  scs = 16 **  $ short constant size.
dsk  205      +*  di_chain   = .f.   1, 16, **  $ ptr to -voa- or -baseblock-.
dsk  206      +*  di_syze    = .f.  17, 16, **  $ length in bits of item.
dsk  207      +*  di_cval    = .f.  33, 16, **  $ short constant value.
dsk  208      +*  di_nwords  = .f.  49,  8, **  $ number of words in item.
dsk  209      +*  di_count   = .f.  57,  8, **  $ number of users of item.
dsk  210      +*  di_addrreg = .f.  65,  8, **  $ address register for item.
dsk  211      +*  di_out     = .f.  73,  8, **  $ deferred output of -dop-.
dsk  212      +*  di_luse    = .f.  81,  8, **  $ number of drops.
dsk  213      +*  di_lword   = .f.  89,  8, **  $ head of -dword- chain.
dsk  214      +*  di_mblk    = .f.  97,  8, **  $ machine block of item.
dsk  215      +*  di_scon    = .f. 105,  1, **  $ 'item is short constant'
dsk  216      +*  di_mw      = .f. 106,  1, **  $ 'item is multi-word'
dsk  217      +*  di_real    = .f. 107,  1, **  $ 'item is floating-point'
dsk  218      +*  di_baseblk = .f. 108,  1, **  $ 'item is in base block'
dsk  219      +*  di_array   = .f. 109,  1, **  $ 'item is array'
dsk  220      +*  di_temp    = .f. 111,  1, **  $ 'item is temporary'
dsk  221      +*  di_const   = .f. 112,  1, **  $ 'item is constant'
dsk  222      +*  di_var     = .f. 113,  1, **  $ 'item is variable'
dsk  223      +*  di_ldrop   = .f. 115,  1, **  $ 'last use in -voa-'
dsk  224      +*  di_anum    = .f. 121,  8, **  $ argument number.
dsk  225 ..s37
     746 .+s66.
rkb   16      +*  scs = 18 **  $ short constant size.
     747      +*  di_chain   = .f.  01, 12, **
     748      +*  di_syze    = .f.  13, 11, **
     749      +*  di_cval    = .f.  24, 18, **
     750      +*  di_nwords  = .f.  42, 08, **
     751      +*  di_count   = .f.  50, 08, **
     752      +*  di_addrreg = .f.  61, 05, **
     753      +*  di_out     = .f.  66, 08, **
     754      +*  di_luse    = .f.  76, 08, **
     755      +*  di_lword   = .f.  84, 08, **
     756      +*  di_mblk    = .f.  92, 08, **
     757      +*  di_scon    = .f. 100, 01, **
     758      +*  di_mw      = .f. 101, 01, **
     759      +*  di_real    = .f. 102, 01, **
     760      +*  di_baseblk = .f. 103, 01, **
     761      +*  di_array   = .f. 104, 01, **
     762      +*  di_temp    = .f. 105, 01, **
     763      +*  di_const   = .f. 106, 01, **
     764      +*  di_var     = .f. 107, 01, **
     765      +*  di_ldrop   = .f. 109, 01, **
     766      +*  di_anum    = .f. 110, 08, **
     767 ..s66
     768
     769      +*  ditemsz =  $ size of -ditem-
     770 .+s10    144
dsk  226 .+s32    128
dsk  227 .+s37    128
     771 .+s66    120
     772          **
     773
     774      size  ditem(ditemsz);  dims ditem(ditemdim);
     775
     776
     777      $   fields in -dword-.
     778
vaxa  92 .+s66.
vaxa  93 .+t10.
     779      +*  dw_word = .f.  1, 18, **  $ word number in item (from left).
     780      +*  dw_madr = .f. 19, 18, **  $ machine addr or register offset.
     781      +*  dw_next = .f. 37,  8, **  $ index of next -dword- in chain.
     782      +*  dw_freg = .f. 45,  8, **  $ index of first -dreg- in chain.
vaxa  94 ..t10
vaxa  95 .+t32.
vaxa  96      +*  dw_madr = .f. 1, 32, **
vaxa  97      +*  dw_word = .f. 33, 18, **
vaxa  98      +*  dw_next = .f. 61, 8, **
vaxa  99      +*  dw_freg = .f. 69, 8, **
vaxa 100 ..t32
vaxa 101 ..s66
dsn   53 .+s10.
dsn   54 .+t10.
dsn   55      +*  dw_word = .f.  1, 18, **  $ word number in item (from left).
dsn   56      +*  dw_madr = .f. 19, 18, **  $ machine addr or register offset.
dsn   57      +*  dw_next = .f. 37,  8, **  $ index of next -dword- in chain.
dsn   58      +*  dw_freg = .f. 45,  8, **  $ index of first -dreg- in chain.
dsn   59 ..t10
dsn   60 .+t32.
dsn   61      +*  dw_madr = .f. 1, 32, **
dsn   62      +*  dw_word = .f. 33, 18, **
dsn   63      +*  dw_next = .f. 61, 8, **
dsn   64      +*  dw_freg = .f. 69, 8, **
dsn   65 ..t32
dsn   66 ..s10
dsk  228 .+s32.
dsk  229      +*  dw_word = .f.  1, 16, **  $ word number in item (from left)
dsk  230      +*  dw_next = .f. 17,  8, **  $ pointer to next -dword- in chain.
dsk  231      +*  dw_freg = .f. 25,  8, **  $ pointer to -dreg-.
dsk  232      +*  dw_madr = .f. 33, 32, **  $ machine addr or register offset.
dsk  233 ..s32
dsk  234 .+s37.
dsk  235      +*  dw_word = .f.  1, 16, **  $ word number in item (from left)
dsk  236      +*  dw_next = .f. 17,  8, **  $ pointer to next -dword- in chain.
dsk  237      +*  dw_freg = .f. 25,  8, **  $ pointer to -dreg-.
dsk  238      +*  dw_madr = .f. 33, 32, **  $ machine addr or register offset.
dsk  239 ..s37
     784      +*  dwordsz =  $ size of -dword-
     785 .+s10    72
dsk  240 .+s32    64
dsk  241 .+s37    64
vaxa 102 .+s66.
vaxa 103 .+t10    60
vaxa 104 .+t32    120
vaxa 105 ..s66
     787          **
     788
     789      size  dword(dwordsz);  dims dword(dworddim);
     790
     791
     792      $   fields in -dreg-.
     793
     794      $   dr_item - pointer to -ditem-
     795      $   dr_word - pointer to -dword-.
     796      $   dr  next - next -dreg- in chain.
     797      $   dr_reg  - machine register containing form.
     798 .+s10.
     799      +*  dr_item = .f. 01, 08, **
     800      +*  dr_word = .f. 09, 08, **
     801      +*  dr_next = .f. 17, 08, **
     802      +*  dr_reg  = .f. 25, 08, **
     803 ..s10
dsk  242 .+s32.
dsk  243      +*  dr_item   = .f.  1, 8, **  $ pointer to -ditem-.
dsk  244      +*  dr_reg    = .f.  9, 8, **  $ machine register containing form.
dsk  245      +*  dr_word   = .f. 17, 8, **  $ pointer to -dword-.
dsk  246      +*  dr_next   = .f. 25, 8, **  $ next -dreg- in chain.
dsk  247 ..s32
dsk  248 .+s37.
dsk  249      +*  dr_item   = .f.  5, 8, **  $ pointer to -ditem-.
dsk  250      +*  dr_word   = .f. 17, 8, **  $ pointer to -dword-.
dsk  251      +*  dr_next   = .f. 25, 8, **  $ next -dreg- in chain.
dsk  252      +*  dr_reg    = .f. 33, 8, **  $ machine register containing form.
dsk  253 ..s37
     804 .+s66.
     805      +*  dr_item = .f. 01, 08, **
     806      +*  dr_word = .f. 09, 08, **
     807      +*  dr_next = .f. 17, 08, **
     808      +*  dr_reg  = .f. 25, 08, **
     809 ..s66
     810
dsk  254      +*  dregsz =
dsk  255 .+s66    60
dsk  256 .+s10    36
dsk  257 .+s32    32
dsk  258 .+s37    64
dsk  259          **
     812
     813      size  dreg(dregsz);  dims dreg(dregdim);
     814
     815      $   -reglis-
     816
     817      $   the entries is this table correspond to the real machine
     818      $   register.  they contain information used to allocate the
     819      $   real machine registers to the dummy registers.
     820
     821      +*  rl_content  = .f. 01, 09, **  $ pointer to -dreg- that is
     822                                        $ 'in' this register or, for
     823                                        $ base types, the -madr/1024-.
     824      +*  rl_type     = .f. 16, 04, **  $ type of item in register.
     825      +*  rl_subtype  = .f. 16, 03, **  $ sub-type of item
     826      +*  rl_perm     = .f. 19, 01, **  $ 'value is permanently in reg'
     827      +*  rl_hold     = .f. 20, 01, **  $ hold bit.
     828      +*  rl_addrhold = .f. 21, 01, **  $ address hold bit.
     829      +*  rl_usevalue = .f. 22, 11, **  $ value for lru allocation
     830
     831      +*  reglissz = 32 **  $ size of -reglis- array.
     832
     833      size  reglis(reglissz);  dims reglis(rhihi);  $ machine reg. list
     834
     835
     836      $   values of -rl_type- field.
     837      $   note that the order of these types corresponds to increasing
     838      $   priority of the register.
     839
     840      +*  rt_dead     = 00 **  $ register is empty
     841      +*  rt_address  = 01 **  $ register contains address of variable
     842      +*  rt_need     = 02 **  $ register contains needed value
     843      +*  rt_live     = 03 **  $ register contains only copy of data
     844      +*  rt_liveaddr = 04 **  $ register contains only copy of address
     845
     846      $   the rest of the types are the same as above but are
     847      $   permanently assigned.
     848
     849      +*  rt_permresv = 8 **   $ permanent reserved value. (r13, etc.)
     850      +*  rt_perm     = 8 + rt_need **
     851      +*  rt_permlive = 8 + rt_live **
     852
     853
     854
     855      $   -lablist-.
     856
     857      $   the -lablist- array is used to hold information about
     858      $   labels in the routine being compiled.
     859
     860 .+labopt.    $ used only if this option is on.
     861      +*  ll_count = .f.  1, 16, **  $ number of times label used.
     862      +*  ll_def   = .f. 17, 16, **  $ -voa- operation defining label.
     863 ..labopt
     864
     865      +*  lablistsz = 32 **   $ size of -lablist-
     866
     867      size lablist(lablistsz); dims lablist(lablistdim);
     868      size  lablistptr(ps);       $ pointer into -lablist-.
     869
     870      $   -pdlist-.
     871
     872      $   the -pdlist- array is used to hold the parameter lists
     873      $   for all calls generated by the program.
     874
dsk  260 .-s32.
     875      +*  pd_madr  = .f.  1, 18, **  $ machine address of parameter.
     876      +*  pd_block = .f. 19,  8, **  $ machine block of parameter.
dsk  261 .+s32.
dsn   67      +*  pd_madr = .f. 1, 32, **
dsn   68      +*  pd_block = .f. 33, 32, **
dsk  264 ..s32
     877
     878+*  pdlistsz =  $ size of pdlist.
     879 .+s10  ws
dsn   69 .+s32  64
     881 .+s66  ws
     882**
     883      size  pdlist(pdlistsz); dims pdlist(pdlistdim);
     884      size  pdlistp(ps);      $ pointer to pdlist.
     885
vaxa 106 .+t10    size  longname(.sds. 6);  $ long routine names.
vaxa 107 .+t32    size  longname(.sds. namelen);  $ long routine names.
     887      dims  longname(vo_sasin);  $ highest entry used.
     888
     889      data    $ initialize -longname- array.
     890      +*  long(en, n) = longname(en) = n **
     891      $   since only standard form on s10, need full set of multi-word
     892      $   comparison procedures.
     893
vaxa 108 .+t10.
     894      long(do_add,   'iadd$m'):
     895      long(do_sub,   'isub$m'):
     896      long(do_mul,   'imul$m'):
     897      long(do_div,   'idiv$m'):
     898      long(do_and,   'band$m'):
     899      long(do_eq,    'bequ$m'):
     900      long(do_ne,    'bneq$m'):
     901      long(do_lt,    'bles$m'):
     902      long(do_ge,    'bgeq$m'):
     903      long(do_or,    'bior$m'):
     904      long(do_exor,  'bxor$m'):
     905      long(do_not,   'bnot$m'):
     906      long(do_fb,    'bfir$m'):
dsc   10      long(do_nb,    'bnum$m'):
     908
     909      long(vo_sasin, 'casi$m'):
     910      long(vo_ccat,  'ccat$m'):
     911      long(vo_in,    'cind$m'):
     912      long(vo_seq,   'cequ$m'):
     913      long(vo_sext,  'cext$m'):
     914      long(vo_easin, 'easi$m'):
     915      long(vo_eext,  'eext$m');
vaxa 109 ..t10
vaxa 110 .+t32.
vaxa 111      long(do_add,   'iadd$mw'):
vaxa 112      long(do_sub,   'isub$mw'):
vaxa 113      long(do_mul,   'imul$mw'):
vaxa 114      long(do_div,   'idiv$mw'):
vaxa 115      long(do_and,   'band$mw'):
vaxa 116      long(do_eq,    'bequ$mw'):
vaxa 117      long(do_ne,    'bneq$mw'):
vaxa 118      long(do_lt,    'bles$mw'):
vaxa 119      long(do_ge,    'bgeq$mw'):
vaxa 120      long(do_or,    'bior$mw'):
vaxa 121      long(do_exor,  'bxor$mw'):
vaxa 122      long(do_not,   'bnot$mw'):
vaxa 123      long(do_fb,    'bfir$mw'):
vaxa 124      long(do_nb,    'bnum$mw'):
vaxa 125
vaxa 126
vaxa 127      long(vo_sasin, 'casi$mw'):
vaxa 128      long(vo_ccat,  'ccat$mw'):
vaxa 129      long(vo_in,    'cind$mw'):
vaxa 130      long(vo_seq,   'cequ$mw'):
vaxa 131      long(vo_sext,  'cext$mw'):
vaxa 132      long(vo_easin, 'easi$mw'):
vaxa 133      long(vo_eext,  'eext$mw');
vaxa 134 ..t32
     916
     917
     918      size  moptab(.sds. 3);  dims moptab(num_mo);
     919       data
     920      moptab(mo_ban) = 'ban':
     921      moptab(mo_bfb) = 'bfb':
     922      moptab(mo_bnb) = 'bnb':
     923      moptab(mo_bno) = 'bno':
     924      moptab(mo_bor) = 'bor':
     925      moptab(mo_bxo) = 'bxo':
     926      moptab(mo_cal) = 'cal':
     927      moptab(mo_ceq) = 'ceq':
     928      moptab(mo_cge) = 'cge':
     929      moptab(mo_cgt) = 'cgt':
     930      moptab(mo_cle) = 'cle':
     931      moptab(mo_clt) = 'clt':
     932      moptab(mo_cne) = 'cne':
     933      moptab(mo_iab) = 'iab':
     934      moptab(mo_iad) = 'iad':
     935      moptab(mo_iao) = 'iao':
     936      moptab(mo_ico) = 'ico':
     937      moptab(mo_idi) = 'idi':
     938      moptab(mo_idt) = 'idt':
     939      moptab(mo_ieq) = 'ieq':
dsj   43      moptab(mo_ifr) = 'ifr':
     940      moptab(mo_ige) = 'ige':
     941      moptab(mo_igt) = 'igt':
     942      moptab(mo_ile) = 'ile':
     943      moptab(mo_ilt) = 'ilt':
     944      moptab(mo_imo) = 'imo':
     945      moptab(mo_imt) = 'imt':
     946      moptab(mo_imu) = 'imu':
     947      moptab(mo_ine) = 'ine':
     948      moptab(mo_isi) = 'isi':
     949      moptab(mo_iso) = 'iso':
     950      moptab(mo_isu) = 'isu':
     951      moptab(mo_jeq) = 'jeq':
     952      moptab(mo_jge) = 'jge':
     953      moptab(mo_jgt) = 'jgt':
     954      moptab(mo_jle) = 'jle':
     955      moptab(mo_jlt) = 'jlt':
     956      moptab(mo_jmn) = 'jmn':
vaxa 135 .+t10    moptab(mo_jmp) = 'jmp':
vaxa 136 .+t32    moptab(mo_jmp) = 'jma':
     958      moptab(mo_jne) = 'jne':
     959      moptab(mo_lda) = 'lda':
     960      moptab(mo_ldf) = 'ldf':
     961      moptab(mo_ldl) = 'ldl':
     962      moptab(mo_ldr) = 'ldr':
     963      moptab(mo_ldw) = 'ldw':
eaa   75 .+t20.
eaa   76      moptab(mo_lla) = 'lla':
eaa   77 ..t20
     964      moptab(mo_lpr) = 'lpr':
     965      moptab(mo_mvw) = 'mvw':
dsu   61      moptab(mo_mvx) = 'mvx':
     966      moptab(mo_rab) = 'rab':
     967      moptab(mo_rad) = 'rad':
     968      moptab(mo_rco) = 'rco':
     969      moptab(mo_rdi) = 'rdi':
     970      moptab(mo_req) = 'req':
     971      moptab(mo_ret) = 'ret':
dsj   44      moptab(mo_rfi) = 'rfi':
     972      moptab(mo_rge) = 'rge':
     973      moptab(mo_rgt) = 'rgt':
     974      moptab(mo_rle) = 'rle':
     975      moptab(mo_rlt) = 'rlt':
     976      moptab(mo_rmo) = 'rmo':
     977      moptab(mo_rmu) = 'rmu':
     978      moptab(mo_rne) = 'rne':
     979      moptab(mo_rsi) = 'rsi':
     980      moptab(mo_rsu) = 'rsu':
dsj   45      moptab(mo_rtr) = 'rtr':
     981      moptab(mo_spr) = 'spr':
     982      moptab(mo_stf) = 'stf':
     983      moptab(mo_stl) = 'stl':
vaxa 137 .+t10    moptab(mo_str) = 'str':
vaxa 138 .+t32    moptab(mo_xjm) = 'xjm':
     985      moptab(mo_stw) = 'stw':
     986      moptab(mo_zeb) = 'zeb':
eaa   78 .+t20.
eaa   79      moptab(mo_hba) = 'hba':
eaa   80      moptab(mo_hbb) = 'hbb':
eaa   81      moptab(mo_hbc) = 'hbc':
eaa   82 ..t20
     987      moptab(mo_zew) = 'zew';
     988
     989      $   -baseblock-
     990
     991      $   this table is used to create a map of the base block
     992      $   addressed by base.  it is a hashed table containing addresses,
     993      $   some local variables, some temporaries, parameter lists,
     994      $   and single-word constants.  it uses a link for hash clashes
     995      $   and is threaded by order of address in block.  (note that this
     996      $   corresponds to the order in which entries are inserted into
     997      $   this table.)
     998
     999
    1000      $   fields of -baseblock-.
    1001
    1002 .+s10.
    1003      +*  bb_chain   = .f. 01, 09, **  $ next entry in block by address
    1004      +*  bb_link    = .f. 10, 09, **  $ link for hash clashes.
    1005      +*  bb_type    = .f. 19, 03, **  $ type of item in block.
    1006      +*  bb_nwords  = .f. 22, 05, **  $ length (in words) of item.
    1007      +*  bb_bptr    = .f. 37, 11, **  $ back pointer. (-dreg- or -voa-)
    1008      +*  bb_pointer = .f. 48, 11, **  $ pointer depending on type.
    1009      +*  bb_addr    = .f. 59, 10, **  $ offset of item in base block.
    1010 ..s10
dsk  266 .+s32.
dsk  267      +*  bb_chain   = .f. 01, 09, **  $ next entry in block by address
dsk  268      +*  bb_link    = .f. 10, 09, **  $ link for hash clashes.
dsk  269      +*  bb_type    = .f. 19, 03, **  $ type of item in block.
dsk  270      +*  bb_nwords  = .f. 22, 05, **  $ length (in words) of item.
dsk  271      +*  bb_bptr    = .f. 33, 11, **  $ back pointer. (-dreg- or -voa-)
dsk  272      +*  bb_pointer = .f. 44, 11, **  $ pointer depending on type.
dsk  273      +*  bb_addr    = .f. 55, 10, **  $ offset of item in base block.
dsk  274 ..s32
    1011 .+s66.
    1012      +*  bb_chain   = .f. 01, 09, **  $ next entry in block by address
    1013      +*  bb_link    = .f. 10, 09, **  $ link for hash clashes.
    1014      +*  bb_type    = .f. 19, 03, **  $ type of item in block.
    1015      +*  bb_nwords  = .f. 22, 05, **  $ length (in words) of item.
    1016      +*  bb_bptr    = .f. 27, 11, **  $ back pointer. (-dreg- or -voa-)
    1017      +*  bb_pointer = .f. 38, 11, **  $ pointer depending on type.
    1018      +*  bb_addr    = .f. 49, 10, **  $ offset of item in base block.
    1019 ..s66
    1020
    1021      +*  baseblocksz =   $ size of entry in bits.
    1022 .+s10    72
dsk  275 .+s32    64
dsk  276 .+s37    64
    1023 .+s66    60
    1024          **
    1025
    1026      +*  baseblockdim = 511 **
    1027      +*  baseblockprime = 499 **
    1028      size  baseblock(baseblocksz); dims baseblock(baseblockdim);
    1029
    1030      $   types used in -bb_type-
    1031      +*  bt_label = 1 **  $ label address.  -bb_pointer- is -lablist-
    1032                           $ index.
    1033      +*  bt_const = 2 **  $ entry is single-word constant.
    1034                           $ -bb_pointer- is -val- index.
    1035      +*  bt_plist = 3 **  $ parameter list. -bb_pointer- points
    1036                           $ into -pdlist-.
    1037
    1038      +*  bt_temp  = 4 **  $ temporary.
    1039      +*  num_bt = 4 **
    1040
    1041
pic    9 .+s32.
pic   10    size pic_case(ps); data pic_case=no;
pic   11    size pic_char(cs);
pic   12 ..s32
    1042
    1043
    1044
    1045      size  xx(1); data xx=yes;  $ to force correct s37 load order.
    1046      $   this required since otherwise dead code that sould be
    1047      $ retained for correct load is eliminated.
    1048      call asmini;   $ initialize everything.
    1049      while  xx;   $ loop until stopped.
    1050          call setup;  $ initialize for generation.
    1051          call asmprog;  $ generate code.
    1052          call endsubr;  $ terminate code for routine.
    1053          end while;
    1054
    1055      $   ***** no exit to here expected. ****
    1056
    1057      exitcode = 0; call asmexit;  $ for lked.
    1058
dsb   89 .+s10  end prog start;
dsk  277 .+s32  end prog start;
dsb   90 .+s66  end subr start;
       1 .=member asmini
       2      subr asmini;   $ code generator initialization.
       3      $   this is the initialization routine for the code generator
       4      $   which is entered first.  it reads parameters, initializes
       5      $   some tables, and opens files.
       6      size  i(ps), j(ps), flg(1);  $ temporaries.
       7      size  cval(ws);     $ constant value for 'pc' option.
       8      size  lnta(ps); dims lnta(8);   $ array for -lntime-.
       9      size  lcp_opt(1);   $ compiler parameter listing option.
      11      size  optval(.sds. namelen);  $ options desired.
dsn   70      size  voafilename(.sds.filenamelen);  $ -voa- file name.
dsn   71      size  codefilename(.sds.filenamelen);  $ loader input file name.
dsn   72      size  appstr(.sds. getapp_len);  $ actual parameter string.
      14
      15      call lstime(comptime);
      16
dsq   67      call getipp(ats_opt, 'ats=1/0');  $ get time stamp option.
dsq   68
      17      $   generate local names for global blocks.
      18      file ocsfile  title=ocs, access=string, linesize=80;
      19      do  i = bl_global to mbadim;
      20          put ocsfile ,column(1) ,'g' :i,i(2,2);
      21          mblknames(i) = .s. 1, 3, ocs;
      22          end do;
      23      call ocsput(0, 2);  $ clear code string.
      24
      25      $   read parameters.
dsn   73 .+s10    call getspp(voafilename, 'voa=*.voa/');
dsk  278 .+s32  call getspp(voafilename, 'voa=voa.tmp/,');
dsb   92 .+s66  call getspp(voafilename, 'voa=voa/');
      28
dsn   74 .+s10    call getspp(codefilename, 'code=*.mac/');
dsk  280 .+s32  call getspp(codefilename, 'code=little.cod/');
dsb   95 .+s66  call getspp(codefilename, 'code=code/');
      30      call getspp(optval, 'opt=dfl/');
      31      $   [ds 2 jun 78  optimizations on by default, as they
      32      $   were enabled for nyu checkout.]
      33 .+defer.
      34 .+ifopt      opt_f = ('f' .in. optval) ^= 0;
      35 ..defer      opt_d = ('d' .in. optval) ^= 0 ! opt_f;
      36 .+labopt     opt_l = ('l' .in. optval) ^= 0;
      37
      38 .+trace.   $ process trace parameter.
      39      call getspp(optval, 'trace=/acdorv');
      40      trace_a = ('a' .in. optval) ^= 0;
      41      trace_c = ('c' .in. optval) ^= 0;
      42      trace_d = ('d' .in. optval) ^= 0;
      43      trace_l = ('l' .in. optval) ^= 0;
      44      trace_o = ('o' .in. optval) ^= 0;
      45      trace_r = ('r' .in. optval) ^= 0;
      46      trace_v = ('v' .in. optval) ^= 0;
      47
      48      trace_any = (trace_a ! trace_c ! trace_d ! trace_l ! trace_o !
      49                  trace_r ! trace_v);
      50 ..trace
      51
vaxa 139 .+t10.
      52      $   parameter unv names universal file.  if not null, then
      53      $   each t10 procedure will begin with  search  ufn
      54      $   command where ufn is universal file name.
      55
      56      call getspp(univfilename, 'unv=t10mac/');
dsp   28
dsp   29      $   parameter end permits generation of end directive at end
dsp   30      $   of code file, for example  end=prg  yields endprg as last line
dsp   31      $   if end=0 specified, no special last line is generated.
dsp   32      call getspp(end_opt,'end=prg/seg');
dsp   33
vaxa 140 ..t10
      57
dsq   69 .+t32  call getipp(iv_opt, 'iv=0/1'); $ integer overflow enable
      58      call getipp(lcs_opt, 'lcs=1/0');
      59      call getipp(lcp_opt, 'lcp=1/0');
dsvb  14 .+s32u.
dsq   71 $    quiet listing by default.
dsq   72      call getipp(lcs_opt, 'lcs=0/1');
dsq   73      call getipp(lcp_opt, 'lcp=0/1');
dsvb  15 ..s32u
      60
eaa   83 .+t20.
eaa   84      call getspp(nsheap_prm,'nsheap=/nsheap');
eaa   85      if .len. nsheap_prm  then $ if want dynamic heap
eaa   86          nsheap_opt = 1;
eaa   87          call stuc(nsheap_prm); $ fold name to primary case
eaa   88          call getspp(nsheap_org,'nshorg=^o2000001/');
eaa   89      else
eaa   90          nsheap_opt = 0;
eaa   91          end if;
eaa   92 ..t20
dsu   62 .+t32h.
dsu   63      call getspp(nsheap_prm,'nsheap=/nsheap');
dsu   64      if  .len. nsheap_prm  then $ if want dynamic heap
dsu   65          nsheap_opt = 1;
dsu   66      else
dsu   67          nsheap_opt = 0;
dsu   68          end if;
dsu   69 ..t32h
dsk  281      call getipp(fag_opt, 'fag=0/1');
dst   37      call getipp(nspage_opt,'nspage=0/1'); $ page alignment opt.
dsn   75
dsn   76      $   get actual parameters specified.
dsn   77      call getapp(appstr, getapp_len);
dsn   78
      61      $   open files.
      63      file voafile access=read, title=voafilename;
dsk  282      call dropsio(voafile, i);  $ set to delete voa file.
eaa   93 .+s66  rewind voafile;
      65      if  codefile ^= 2  then  $ if separate code file.
      66          file codefile access=put, title=codefilename,linesize=80;
      67          end if;
dst   38 .+enp.
dst   39      call getspp(enpfilename, 'enp=0/t.rep');
dsta   1      call getipp(enporg, 'enporg=0/0');
dst   41      if  enpfilename .sne. '0' then $ if enp file wanted
dst   42        enpopt = yes;
dst   43        file  enpfile access=  get, title=enpfilename;
dst   44        while 1;
dst   45         size enpent(.sds. 20);
dst   46         size enptyp(.sds. 16);
dst   47            get enpfile ,skip :enptyp,a(16) :enpent,a(20);
dst   48            if  filestat(enpfile,end) then quit; end if;
dst   49            if  enptyp .sne. '        p       ' then cont; end if;
dst   50            countup(enptot, enpmax, 'enp readin');
dst   51            size enpl(ps),brkc(ws);
dst   52            enpl = brkc(enpent,1, 1r,);
dst   53            if enpl>0 then .len. enpent = enpl; end if;
dst   54            enpara(enptot) = enpent;
dst   55            end while;
dst   56         end if;
dst   57 ..enp
dst   58
      68      $   set up titling.
      69      call ltitlr(assemblerlevel);
      70      call stitlr(0, 'little compilation - code generation phase.');
      71
      72      $   list parameters, if desired.
      73      if  lcp_opt then  $ parameter list wanted.
      74          call stitlr(1, 'parameters for this code generation.');
dsn   80
dsn   81          if  .len. appstr  then $ if any explicitly specified.
dsn   82              textl(appstr)  endl endl
dsn   83              end if;
dsn   84
      75          textl('voa file name: voa = ') textl(voafilename)
      76      textl('.  code file name: code = ') textl(codefilename)
      81          charl(1r.) endl
      82
vaxa 141 .+t10.
dsp   34      textl('end line: end = ')
dsp   35      textl(end_opt)
dsp   36      textl('.' )
      83      if  (.len. univfilename)  then  $ if universal file.
      84          textl('universal file: unv = ')
dsp   37          textl(univfilename)  textl('.')
      86          end if;
dsp   38      endl
eaa   94
eaa   95 .+t20.
eaa   96      textl('nsheap: nsheap = ') textl(nsheap_prm)
eaa   97      textl('.  nsheap origin: nshorg = ')
eaa   98      textl(nsheap_org)  textl('.') endl
eaa   99 ..t20
dsu   70 .+t32h.
dsu   71      textl('nsheap: nsheap = ') textl(nsheap_prm)
dsu   72      textl('.') endl
dsu   73 ..t32h
eaa  100
vaxa 142 ..t10
      87          textl('optimizations to be performed: opt = ')
      88 .+defer.     if  (opt_d) charl(1rd)
      89 .+ifopt      if  (opt_f) charl(1rf)
      90 ..defer
      91 .+labopt     if  (opt_l) charl(1rl)
      92          if  (opt_d+opt_l = 0)  charl(1r0)
      93
      94 .+trace.
      95          if  trace_any then  $ print trace options.
      96              textl('.  tracing options: trace = ')
      97              if  (trace_a) charl(1ra)
      98              if  (trace_c) charl(1rc)
      99              if  (trace_d) charl(1rd)
     100              if  (trace_l) charl(1rl)
     101              if  (trace_o) charl(1ro)
     102              if  (trace_r) charl(1rr)
     103              if  (trace_v) charl(1rv)
     104              end if;
     105 ..trace
     106
dsk  283          charl(1r.) endl
dsq   75          textl('time stamp: ats = ')
dst   59          intlp(ats_opt, 1) textl('.  nspage: nspage = ')
dst   60          intlp(nspage_opt,1) charl(1r.)
dst   61          endl
dsk  284
dsk  285          textl('functions alter globals: fag = ') intlp(fag_opt, 1)
dsq   77 .+t32  textl('.  iv: iv = ') intlp(iv_opt,1)
dsk  286          charl(1r.) endl endl
     108          end if;
     109
     110
     111
     112      $   if statistics are desired, write headers.
     113      if  lcs_opt then  $ write header.
     114          call stitlr(1, 'statistics and error messages.');
     115          endl textl('procedure')
     116          tabl(30) textl('const')
     117          tabl(40) textl(' base')
     118          tabl(50) textl(' code')
     119          tabl(60) textl('local')
     120          tabl(70) textl('temps')
     121          tabl(90) textl('module')
     122          tabl(100) textl('global')
     123          endl endl
     124      else    $ write different subtitle.
     125          call stitlr(1, 'error messages.');
     126          end if;
     127
     128
     129
     130
     131      end subr asmini;
       1 .=member setup
       2      subr setup;   $ initialize to process a new subroutine.
       3      $   this routine is called to begin processing a new routine.
       4      $   it initializes tables, reads data from the -voa- file, and
       5      $   emits the initial routine starting code.  in addition, this
       6      $   routine decides which variables or base addresses should be
       7      $   permanently assigned to a register and assigns them if any
       8      $   are to be assigned.
       9      size  i(ps), j(ps), k(ps);  $ temporaries.
      10      size  namep(ps);            $ pointer to routine name.
      11      size  numargs(ps);          $ number of arguments to routine.
      12      size  hap(ps);              $ -ha- pointer.
      13      size  haent(hasz);          $ -ha- entry.
      14      size  reg(ps);              $ -dreg- used for peramanent value.
      15      size  flg(1);               $ flag array for permanent assignment.
      16      size  addr(mps);            $ machine address.
      17      size  mblk(ps);             $ machine block.
      18      size  tempaddr(mps);        $ address in temporary block.
      19      size  numglobs(ps);   $ number of globals.
      20      size  totcnt(ps);  $ total count for modes.
      21      size  lastcnst(ps);         $ last constant entry so far.
dsj   46      size  moff(mosize);     $ address offset.
      22
      23
      24      $   the first thing to do is to initialize the tables used for
      25      $   generating code for a routine.
      26
      27      $   first, clear the -dreg- table by putting all entries on the
      28      $   free chain.
      29      do  i = 1 to dregdim-1;  $ scan over all but last.
      30          dr_next dreg(i) = i+1;  $ chain to next.
      31          end do;
      32      dr_next dreg(dregdim) = 0;  $ show end of chain.
      33      dregfree = 1;  $ show first is free.
      34
      35      $   clear the -dword- table.
      36      do  i = 1 to dworddim-1;  $ scan all but last.
      37          dw_next dword(i) = i+1;  $ build free chain.
      38          end do;
      39      dw_next dword(dworddim) = 0;  $ show last in chain.
      40      dwordfree = 1;  $ show first is free.
      41
      42      $   do the same for -ditem-.
      43      do  i = 1 to ditemdim-1;  $ scan all but last.
      44          di_out ditem(i) = i+1;  $ chain to next.
      45          end do;
      46      di_out ditem(ditemdim) = 0;  $ show last in chain.
      47      ditemfree = 1;  $ show first is free.
      48
      49      do  i = 1 to baseblockdim;  baseblock(i) = 0;  end do;
      50
      51      baseblockfree = baseblockdim;
      52      basefirst = 0;  baselast = 0;  baselastaddr = 1;
      53
      54      codethis = 0;  $ clear estimated length of code.
      55
      56 .+defer.     $ clear -dops-.
      57      if  opt_d then  $ if optimization is in effect.
      58          do  i = 1 to dopsdim-1;  $ chain all to next.
      59              dp_chain dops(i) = i+1;  $ chain one to next.
      60              end do;
      61          dp_chain dops(dopsdim) = 0;  $ chain last to nothing.
      62          dopfree = 1;  $ show first is on free chain.
      63          end if;
      64 ..defer
      65
      66
      67      $   clear machine register table.
      68      do  i = r0 to rhihi;
      69          reglis(i) = 0;  $ show register dead.
      70          end do;
      71
      72      reguseval = 0;  $ reset register usage count.
vaxa 143
vaxa 144
vaxa 145 .+t32    regmask = 0;   $ show no registers used yet.
      73
      74      +*  checkvof(ptr, lim) =  $ check file dimensions.
      75          ptr = vf_hi vof;  $ get dimension
      76      if  (vf_hi vof > lim)  call aermey(3);  $ if data too big.
      77          **
      78
      79
      80      $   read the -voa- file.  loop until a routine trailer
      81      $   frame is read.
      82      while  yes;  $ loop until 'quit'ed.
      83      read voafile, vof;  $ get header frame.
      84      if  filestat(voafile,end)  then  $ if premature end
      85          textl('error - premature end of voa file')  endl
      86          call aermey(37);  $ need new error number.
      87          end if;
      88          go to l(vf_code vof) in 0 to num_vh;  $ select frame type.
      89
      90 /l(vh_eof)/      $ end-of-file frame.
      91          exitcode = 0; call asmexit;  $ call termination routine.
      92
      93 /l(vh_hdr)/      $ file header frame.
      94          cont while;  $ ignore this frame.
      95
      96 /l(vh_asm)/      $ routine header frame.
      97          lablistptr = vf_lablistp vof;  $ get highest lablist value.
      98      if  (lablistptr>lablistdim)  call aermey(39);  $ if overflow.
      99          do  i = 1 to lablistptr;  lablist(i) = 0; end do;  $ clear.
     100          namep = vf_sub1 vof;  $ -ha- pointer of routine name.
     101          subrtype = vf_sub2 vof;  $ get routine type.
     102          numargs = vf_subrargs vof;  $ get number of arguments.
     103          ha_0 = vf_ha0 vof;  $ ha index of constant zero.
     104          ha_1 = vf_ha1 vof;  $ ha index of constant one.
     105 .+trace  trace_c = vf_listcode vof;  $ set code trace option.
     106 .+trace  trace_any = (trace_c ! trace_d ! trace_o ! trace_r !
     107 .+trace      trace_a ! trace_l ! trace_v);
     108          cont while;  $ got all needed info.
     109
     110 /l(vh_voa)/      $ -voa- frame.
     111      checkvof(voaptr, voadim);  $ check and set dimension.
     112      read voafile, voa(1) to voa(voaptr);
     113          voaptr = voaptr-1;  $ adjust pointer to last used.
     114          cont while;
     115
     116 /l(vh_ha)/       $ -ha- frame.
     117          $   the -ha- is transmitted packed.  must read it in
     118          $   packed format into the top of the -ha- and then unpack
     119          $   it into the bottom of the array.
     120          i = hadim - (vf_hi vof) + 1;  $ set to place to start.
     121      read voafile, ha(i) to ha(hadim);
     122          hap = 0;  $ initially, start to fill at bottom.
     123          do  i = i to hadim;  $ scan received packed info.
     124              haent = ha(i);  $ get first packed entry.
     125              do  j = 1 to ha_zerents haent;  $ insert zero entries.
     126                  hap = hap+1; ha(hap) = 0;
     127                  end do;
     128              hap = hap+1; ha(hap) = haent;  $ insert entry.
     129              end do;
     130          do  i = hap+1 to hadim;  $ clear rest of -ha-.
     131              ha(i) = 0;
     132              end do;
     133          cont while;
     134
     135 /l(vh_names)/    $ -names- array frame.
     136      checkvof(i, namesdim);  $ check and set dimension.
     137      read voafile, names(1) to names(i);
     138          cont while;
     139
     140 /l(vh_xarg)/     $ -xarg- frame.
     141          checkvof(i, xargdim);  $ check and set dimension.
     142      read voafile, xarg(1) to xarg(i);
     143          cont while;
     144
     145 /l(vh_val)/      $ -val- array frame.
     146          checkvof(valptr, valdim);
     147          read voafile, val(1) to val(valptr);
     148          cont while;
     149
     150 /l(vh_mba)/      $ -mba- frame.
     151          checkvof(mbaptr, mbadim);
     152          read voafile, mba(1) to mba(mbaptr);
     153          do  i = 1 to num_bl; mba(i) = 0; end do;  $ clear special.
     154          cont while;
     155
     156 /l(vh_eos)/      $ end-of-routine frame.
     157          quit while;  $ exit from loop to continue with initialization.
     158          end while;
     159
     160
     161      sdsname(currsubname, namep);   $ get current routine name.
     162
     163      $   reserve parmreg is procedure has parameters.
     164
     165      if (numargs)  rl_type reglis(parmreg) = rt_permresv;
     166
     167      call eminit(1, numargs, subrtype);  $ emit initialization code.
     168
dss   18 .+t32u  lablorg = lablorg + labluse;
     169      $   get a new label and use it for the label for returns.
     170      countup(lablistptr, lablistdim, 'lablist');  $ new label.
     171      returnlab = lablistptr;  $ use this as the return label.
     172      lablist(returnlab) = 0;  $ clear -lablist- entry.
     173      labluse = lablistptr;  $ set last use pointer.
     174
     175      $   must make a pass over the -voa- to do the following:
     176      $   1)  allocate all multi-word constants to the constant block.
     177      $   2)  allocate all multi-word temporaries to the temp block.
     178      $   3)  set flags indicating whether or not an operand can be
     179      $       permanently assigned to a register.
     180      $   4)  clear -inreg- fields of operands.
     181      $   5)  count subroutine calls.
     182      $   6)  decrease usage count for a variable for each time it
     183      $       appears in subroutine or function calls.
     184      $   7)  chain -voa- operations for faster access.
     185      $   8)  if label optimization is wanted, indicate where label
     186      $       is defined and also count uses of labels.
     187      $   9)  change return operations into a goto to the return label.
     188      numglobs = 0;
     189      numcalls = 0;  $ initially no calls.
     190      addr = 1;  $ set current address in constant block to start.
     191      lastcnst = 0;  $ show no nulti-word constants yet.
     192      tempaddr = 1;  $ set current address in temporary block.
     193      voahead = 0;  $ show nothing in -voa- op chain yet.
     194      totcnt = 0;  $ no counts.
     195      do  i = 1 to voaptr;   $ scan -voa-.
     196          if  vv_opb voa(i) then  $ this is operation.
     197              $   chain in operation.
     198              if  voahead then  $ chain this to last.
     199                  vv_chain voa(voalast) = i; $ chain this in.
     200              else    $ this is head of chain.
     201                  voahead = i;  $ put on top of chain.
     202                  end if;
     203
     204              voalast = i;  $ show this is last one.
     205
     206              $   check for operation which is subroutine
     207              $   or function call.  in this case global
     208              $   variables must be stored so the number of such calls
     209              $   is recorded for computing which variables should
     210              $   permanently reside in a register.
     211              if  vv_opcode voa(i) = vo_scall !   $ if subroutine call.
     212                  vv_opcode voa(i) = vo_fcall then  $ or function call.
     213                  numcalls = numcalls + 1;  $ count the call.
dsk  287                  if  (vv_opcode voa = vo_fcall & fag_opt = no)
dsk  288                      cont do; $ skip functions if globals not altered.
     215                  $   loop over all arguments.
     216              if  (vv_arglen voa(i) = 0)  cont do;  $ if no args.
     217              do  j = vv_argbeg voa(i) to vv_argbeg voa(i)
     218                  + vv_arglen voa(i) - 1;
     219                  k = xa_voa xarg(j);
     220                  $   if not constant or temporary and has a usage
     221                  $   count, then decrement by two to allow for
     222                  $   work needed for saving and restoring.
     223                  if  (vv_temb voa(k)) cont do;  $ skip temps.
     224                  if  (vv_const voa(k)) cont do;  $ and consts.
     225                  if  (vv_mblk voa(k) >= bl_global) cont do;
     226                  if  (vv_varnuse voa(k) < 2) cont do;
     227
     228                  $   else, decrement.
     229                  vv_varnuse voa(k) = vv_varnuse voa(k) - 2;
     230                  end do;
     231
     232
     233              $   change returns to gotos.
     234              elseif  vv_opcode voa(i) = vo_return then  $ this is one.
     235                  vv_opcode voa(i) = vo_goto;  $ set new operation.
     236                  vv_inp1 voa(i) = returnlab;  $ set target label.
     237 .+labopt.
     238                  if  (opt_l)    $ count uses of label.
     239                      ll_count lablist(returnlab) =
     240                          ll_count lablist(returnlab) + 1;
     241              elseif  vv_opcode voa(i) = vo_lab then  $ this defines.
     242                  if  (opt_l)  ll_def lablist(vv_inp1 voa(i)) = i;
     243              else    $   this may use a label so call routine.
     244                  if  (opt_l)  call labcount(i, 1);  $ count upwards.
     245 ..labopt
     246              end if;
     247              cont do;  $ done with this entry.
     248              end if;
     249
     250          vv_ppdata voa(i) = no;  $ initially.
     251          vv_inreg voa(i) = 0;  $ show not in a register.
     252          if  (vv_type voa(i) = 0) cont do;  $ skip routine entries.
     253          if  vv_const voa(i) then  $ if constant.
     254              $   if this is single word constant that can
     255              $   be represented safely in octal.
rkb   17              if vv_syze voa(i) <= scs   $ if short,
     257                  & tmctab(vv_lextype voa(i)) <= tmc_b  then
     258                  if  (vv_signbit voa(i)) vv_syze voa(i) = mws;
     259                  $ can have in register if not short constant.
     260                  vv_ppdata voa(i) = vv_syze voa(i) > mps;
     261              else    $ multi-word constant.
     262                  vv_mblk voa(i) = bl_const;  $ in constant block.
     263                  k = vv_syze voa(i);    $ copy in case overflow.
     264                  addr = addr + (k + (mws-1))/mws;
     265                  vv_madr voa(i) = addr-1;  $ set offset.
     266                  $   chain constants via -dimn-.
     267                  if  lastcnst  then  $ if not first in chain.
     268                      vv_dimn voa(lastcnst) = i;  $ chain last to this.
     269                  else    $  first in chain.
     270                      mb_chain mba(bl_const) = i;  $ put in head.
     271                      end if;
     272                  lastcnst = i;  $ set last to this.
     273                  end if;
     274          elseif  vv_temb voa(i) then  $ this is temporary.
     275              if  vv_syze voa(i) > mws then  $ is multi-word temp.
     276                  vv_mblk voa(i) = bl_temp;  $ set block.
     277                  k = vv_syze voa(i);   $ copy in case overflow.
     278                  tempaddr = tempaddr + (k + (mws-1))/mws;
     279                  vv_madr voa(i) = tempaddr-1;   $ set address.
     280                  end if;
     281          else    $   not constant or temporary.
     282 .-vvfrs  vv_frsdata voa(i) = 0;  $ clear head of data chain
     283 .+vvfrs  vvfrsdata(i) = 0;    $ clear head of data chain
     284              if  vv_isafnct voa(i) = no then  $ ok.
     285                  if  vv_syze voa(i) <= mws & vv_dimn voa(i) = 0 then
rkb   18                      if  (vv_argno voa(i)=0)  vv_ppdata voa(i) = yes;
     287                      if  (vv_mblk voa(i) >= bl_global)
     288                          numglobs = numglobs + 1;
     289                      end if;
     290              $   list address in generated code.
     291                  if  (i^=1)  call eminit(2, i, i);
     292
     293                  end if;
     294
     295              end if;
     296
     297          $   if can address as data, increment the total count for
     298          $   that arithmetic mode.
     299          if  (vv_ppdata voa(i))  $ do increment.
     300              totcnt = totcnt +
     301                  vv_varnuse voa(i);  $ add to count.
     302
     303          end do;
     304
     305      $   if the total count for any mode is too small, set it to
     306      $   a higher value to avoid trivial variables in registers.
     307      $   also decrease counts by number of globals*number of calls.
     308      totcnt = idim(totcnt, numglobs*numcalls);
     309      if  (totcnt < 20) totcnt = 20;
     310
     311      if  (voahead) vv_chain voa(voalast) = 0;  $ end the chain.
     312
     313
     314      $   next, end the constant chain, if it exists, and then
     315      $   allocate space in the base block for the addresses of the
     316      $   parameters to the current routine.
     317      mb_len mba(bl_const) = addr-1;  $ set length of const block.
     318      mb_len mba(bl_temp) = tempaddr-1;  $ set length of temp block.
     319      if  (lastcnst) vv_dimn voa(lastcnst) = 0;  $ end last chain.
     320
     321      $   see if the current routine is a function.  if so, then
     322      $   allocate space for the return value in the base block.
     323      if  subrtype = st_fnct then   $ this is a function.
     324          vv_mblk voa(1) = bl_base;  $ show in base block.
     325          i = (vv_syze voa(1) + mws-1) / mws;
     326          vv_madr voa(1) = i;
     327          baselastaddr = baselastaddr + i;
     328          call eminit(2, 1, 1);
     329          end if;
     330
dsu   74 .+t32h.
dsu   75 $    see if nsheap option on. if so, see if nsheap nameset
dsu   76 $    referenced in current procedure, in which case indicate
dsu   77 $    references to the nameset are to be made dynamic.
dsu   78      nsheap_this = no; $ assume no refrences possible
dsu   79 ..t32h
     331      do  i = bl_global to mbaptr;
     332          if  (mb_used mba(i) = no)  cont do;
     333          sdsname(dopsname, mb_ha mba(i));
     334          mbanames(i) = dopsname;
dsu   80 .+t32h.
dsu   81           if nsheap_opt then
dsu   82              if  dopsname .seq. nsheap_prm  then $ if heap block
dsu   83                  nsheap_blk = i;
dsu   84                  nsheap_this = yes;
dsu   85                  end if;
dsu   86              end if;
dsu   87 ..t32h
     335          end do;
     336
     337      $   check to see if variables should be permanently assigned
     338      $   to registers.
     339
     340      $   see if any data can be permanently assigned.
     341      $   will try to get at most 5 items permanently assigned to
     342      $   registers.
     343      i = 0;
dsu   88 .+t32h.
dsu   89 $    if heap block, reserve two registers which will contain the
dsu   90 $    byte and word address of the start of the nameset during
dsu   91 $    execution of the procedure.
dsu   92      if nsheap_this then  $ if need to reserve registers.
dsu   93          nsheapreg_w = rhi;
dsu   94          nsheapreg_b = rhi-1;
dsu   95          i = 2;  $ indicate registers reserved.
dsu   96          end if;
dsu   97 ..t32h
     344      until  i >= 5 ;  $ loop until no more.
     345
     346              $   see if there is something that can be permanent.
     347              call getperm(totcnt/20+1);  $ get variable.
     348
     349              $   if none, set flag and exit.
     350              if  (voaep = 0)  quit until; $ if none.
     351
     352              $   otherwise, assign to next register.
     353              assign(reg, va_spec);  $ assign to a dummy register.
     354
vaxa 146 .+t10.
     355              rl_content reglis(rlo+i) = reg;  $ show owner.
     356              rl_type reglis(rlo+i) = rt_perm;  $ set type.
vaxa 147 ..t10
vaxa 148 .+t32.
vaxa 149              rl_content reglis(rhi-i) = reg;  $ show owner.
vaxa 150              rl_type reglis(rhi-i) = rt_perm;  $ set type.
vaxa 151 ..t32
vaxa 152
vaxa 153
     357              vv_ppdata voa(voaep) = no;  $ show cannot be perm again.
     358              i = i+1;  $ count register used.
     359          end until;
     360
vaxa 154 .+t10    nextgfree = rlo+i;  $ show next available register.
vaxa 155 .+t32    nextgfree = rhi-i;  $ show next available register.
     362
     363      $   if label optimization wanted, call routine.
     364 .+labopt if  (opt_l) call labfixup;
     365
     366
     367      pdlistp = 0;  $ no parameter lists yet.
     368
     369      $   emit the code to initialize a routine.
     370
     371
     372      call eminit(3, 1, 2);
     373
     374      $   finally, load permanent data values.
     375      do  i = rlo to rhi;  $ scan registers.
     376          if  rl_type reglis(i) = rt_perm then  $ should load data.
dsj   47              getvar(rl_content reglis(i), gd_intoreg, j, i, moff);
     378              rl_perm reglis(i) = yes;   $ show to be permanent.
     379              end if;
     380          end do;
     381
     382 .+trace.     $ generate trace code.
     383      if  (trace_d) call dumpdregs;
     384      if  (trace_r) call dumpmregs;
     385 ..trace
     386
     387      end subr setup;
       1 .=member eminit
       2      subr eminit(case, nargs, ptype); $ emit initial code for proc.
       3      $   emit initial t10 code for procedure.
       4      size  case(ps);         $ case.
       5      size  nargs(ps);       $ number of arguments
       6      size  ptype(ps);       $ procedure type.
       7      size  i(ps);           $ loop index.
dsw    9          size p(ps); $ position
       8      size  d(cs);           $ access/definition code character.
       9      size  dops(mcs);  $ t10 op to put out.
      10      size  blk(ps);         $ machine block.
      11      size  dop(ps);
dsw   10      size blkname(.sds. namelen); $ block name
      12
      13      go to l(case) in 1 to 3;
      14 /l(1)/  $ to start procedure.
      15
      16      .s. 1, 80, ocs = '';  $ clear ocs.
vaxa 156 .+t10.
      17      $   if universal file specified, put out search directive.
      18      if  .len. univfilename  then
      19          put ocsfile ,column(9) ,'search'
      20          ,column(17) :univfilename,a;
      21          call ocsput(0,0);
      22          end if;
vaxa 157 ..t10
      23
      24      .s. 9, 3, ocs = 'dsp';
      25      put ocsfile ,column(17)
      26          :currsubname,a ,
      27          ',' :nargs,i ,',' :ptype,i  ,x(30)
dsq   78          ,column(33)
dsq   79          ,tmcscom   $ comment
dsq   80          ,' * * ' :currsubname,a(0,1)
      29          ,' * *';
      30      call ocsput(0, 0);  $ put code line.
      31
vaxa 158 .+t10    put ocsfile ,column(1) ,'; compiled by t10.'
dsq   81 .+t32.
dsq   82          put ocsfile ,column(1) ,tmcscom ,' compiled '
dsq   83 .+t32u   ,'t32u by '
dsq   84 .+t32v   ,'t32v by '
dsq   85 ..t32
dsq   86          ;
dsq   87          if  ats_opt  then $ if want time stamp
dsq   88              put ocsfile ,assemblerlevel ,' on '
dsq   89                  :comptime,a;
dsq   90              end if;
      35      call ocsput(0,0);  $ put line.
      36      .s. 1, 80, ocs = '';  $ clear ocs.
dss   19 .+t32u.
dss   20      call renblk(bl_base);
dss   21      call renblk(bl_const);
dss   22      call renblk(bl_temp);
dss   23      call renblk(bl_local);
dsw   11 $    avoid 'g--' symbols for unix; they are too much for 'as'.
dsw   12      do i = bl_global to mbaptr;
dsw   13          sdsname(blkname, mb_ha mba(i)); $ get name
dsw   14          while 1; $ map $ in name to _
dsw   15              p = '$' .in. blkname;
dsw   16              if (p=0) quit; $ if no more $'s in name.
dsw   17              .ch. p, blkname = 1r_; $ map $ to _.
dsw   18              end while;
dsw   19          mblkname(i) = blkname; $ substitute expanded name.
dsw   20          end do;
dss   24 ..t32u
      37      return;
      38 /l(2)/  $ put out address of variable as comment.
      39      i = nargs;
      40      sdlname(dopsname, vv_naym voa(i));  $ get (long) name.
dsq   91      put ocsfile ,column(1)
dsq   92          ,tmcscom
dsq   93          ,'='
dsq   94          ,column(9)
      42          :dopsname,a(12) ,x;   $ put name
      43      if  vv_argno voa(i)  then  $ if argument.
vaxa 160 .+t10    put  ocsfile ,'@+' :vv_argno voa(i)-1,i
vaxa 161 .+t10        ,'(r' :parmreg-1,i  ,')';
dsq   95 .+t32.
dsq   96          put  ocsfile
dsq   97              ,tmcsind
dsq   98              ,'+'
dsq   99              :vv_argno voa(i) * mcpw,i ,'(ap)';
dsq  100 ..t32
      46      else  $ otherwise, write block, offset.
      47          put ocsfile :mblkname(vv_mblk voa(i)),a ,'+'
vaxa 163 .+t10        :vv_madr voa(i)-1,i;   $ put offset.
vaxa 164 .+t32        :(vv_madr voa(i)-1) * mcpw,i;  $ put offset.
      49          end if;
      50          call ocsput(0,0);
      51      return;
      52 /l(3)/  $ put out nameset declarations.
vaxa 165 .+t10.
      53      $    put out nameset declarations, dnd for defined namesets,
      54      $   dna for accessed namesets.
eaa  102
eaa  103 .+t20.
eaa  104      $ see if nsheap option on. if so, see if nsheap nameset
eaa  105      $ referenced in current procedure, in which case indicate
eaa  106      $ references to the nameset are to be extended.
eaa  107      nsheap_this = no; $ assume no references possible.
eaa  108      nsheap_blk = 0; $ assume no references.
eaa  109      if  nsheap_opt then
eaa  110          do  i = bl_global to mbaptr;
eaa  111              sdsname(blkname, mb_ha mba(i));  $ get name.
eaa  112              call stuc(blkname); $ make upper case.
eaa  113              if  blkname .sne. nsheap_prm  then cont do; end if;
eaa  114              $ here if found
eaa  115              nsheap_blk = i;
eaa  116              nsheap_this = yes;
eaa  117              quit do;
eaa  118              end do;
eaa  119
eaa  120          if  nsheap_this  then $ if references
eaa  121              $ add extra descriptive line if extended addressing
eaa  122              put ocsfile ,column(1) , '; extended addressing for '
eaa  123                  :nsheap_prm,a
eaa  124                  ,' (g' :nsheap_blk,i ,')'
eaa  125                  ,' with origin ' :nsheap_org,a ,skip;
eaa  126              call ocsput(0,0);  $ put line.
eaa  127              .s. 1,80, ocs = '';
eaa  128              end if;
eaa  129          end if;
eaa  130 ..t20
      55      do  i = bl_global to mbaptr;  $ loop over global namesets
dsu   98 .+t20    if nsheap_this & (i=nsheap_blk) then cont do; end if;
      56          if  mb_def  mba(i)  then  d = 1rd;  $ if defined.
      57          elseif  mb_used mba(i)  then d = 1ra;  $ if access.
      58          else  cont do;  $ skip if neither.
      59              end if;
      60          sdsname(dopsname, (mb_ha mba(i)));  $ get block name.
      61          .s. 9, 2, ocs = 'dn';
      62          put ocsfile ,column(11) :d,r(1)
      63              ,column(17) :dopsname,a ,','
      64              :mblkname(i),a ,',' :mb_len mba(i),i ;
      65          call ocsput(0, 0);
      66          end do;
      67      $   reserve internal blocks.
      68      do  i = 1 to 3;
      69          if  i=1  then  blk = bl_const;  dop = 1rr;
      70          elseif  i=2  then  blk=bl_temp;  dop = 1rw;
      71          elseif  i=3  then  blk=bl_local;  dop = 1rw;  end if;
      72          if  (mb_len mba(blk)=0)  cont do;
      73          .s. 9, 2, ocs = 'db';
      74          .ch. 11, ocs = dop;
      75          put ocsfile, column(17)
      76              :mblkname(blk),a ,','  $ internal block name.
      77              :mb_len mba(blk),i;
      78          call ocsput(0, 0);  $ put code line.
      79          end do;
vaxa 166 ..t10
      80      $   indicate start of code phase.
      81      put ocsfile ,column(9), 'dsc'
      82          ,column(17) :currsubname,a;  $ indicate start of code.
      83      call ocsput(0, 0);  $ put code.
      84      put ocsfile ,column(9) ,'ent'
      85          ,column(17) :currsubname,a;
      86      call ocsput(0,0);  $ put line.
dst   62 .+enp.
dst   63      if  enpopt then  $ if enp op wanted
dst   64          enpnum = 0;
dst   65          do  i = 1 to enptot;
dst   66              if  enpara(i) .seq. currsubname then $ if match
dst   67                  enpnum = i;
dst   68                  quit do;
dst   69                  end if;
dst   70              end do;
dst   71          if enpnum=0 then enpnotfound = enpnotfound + 1;end if;
dst   72          put ocsfile ,column(9) ,'enp' ,column(17)
dst   73             :currsubname,a ,',#' :(enpnum+enporg),i;
dst   74          call ocsput(0,0);
dst   75          end if;
dst   76 ..enp
dsu   99 .+t32h.
dsu  100      if  nsheap_this  then $ if references to heap.
dsu  101          put ocsfile ,column(9) ,'lha' ,column(17)
dsu  102          ,'r' :nsheapreg_b-1,i ,',r' :nsheapreg_w-1,i
dsu  103          ,',' :mblkname(nsheap_blk),a;
dsu  104          call ocsput(0,0); $ emit line
dsu  105          end if;
dsu  106 ..t32h
      87      .s. 1, 80, ocs = '';
      88      end subr eminit;
dssa   1 .+t32u.
dss   26      subr renblk(bl);
dss   27
dss   28 $    for unix only, generate unique name for 'local' blocks.
dss   29 $    the second and third characters are put in upper case to reduce
dss   30 $    probability of name clash with user names.
dss   31
dss   32      size bl(ps);
dss   33      size s(.sds. 2);
dss   34      s = .s. 2, 2, mblknames(bl);
dss   35      .s. 1, 1, s = .s. (totprocs/26)+1, 1,
dss   36        'abcdefghijklmnopqrstuvwxyz';
dss   37      .s. 2, 1, s = .s. 1 + totprocs - 26*(totprocs/26), 1,
dss   38        'abcdefghijklmnopqrstuvwxyz';
dss   39      call stuc(s);
dss   40      .s. 2, 2, mblknames(bl) = s;
dss   41      .s. 2, 2, mbanames(bl) = s;
dss   42      end subr renblk;
dss   43 ..t32u
       1 .=member labfix
       2 .+labopt.    $ routine used for label optimization.
       3      subr labfixup;  $ clean up branch structure.
       4      $   this routine is called when label optimization is
       5      $   desired.  it will make as many passes over the operations
       6      $   in the -voa- as needed.  it does the following things:
       7      $   1)  deletes unreferenced labels.
       8      $   2)  deletes dead code.
       9      $   3)  deletes branches to the next statements.
      10      $   4)  changes destinations of branches to -goto-s.
      11      $   5)  fixes up things like    if x,3; goto,4;lab,3
      12      $       by changing it to    ifnot x,4
      13      size  voap(ps);         $ current index into -voa-.
      14      size  modfl(1);         $ flag indicating if any modifications
      15                              $ were made in the last pass over -voa-.
      16      size  lab(ps);          $ label being referenced.
      17      size  i(ps), j(ps);     $ temporaries.
      18      size  targsp(ps);       $ pointer to targets array.
      19      size  targs(ps); dims targs(10);
      20
      21      $   will loop over the -voa- until the last pass made
      22      $   no changes.
      23      until  modfl = no;
      24          modfl = no;  $ show no changes in this pass.
      25          $   start at top of -voa-.
      26          voap = voahead;    $ set to first in chain.
      27          while  voap;  $ while more operations.
      28
      29              $   first check for the case of an if/ifnot followed
      30              $   by a goto followed by the target label being defined.
      31              until  yes;  $ quit if not this case.
      32                  if  (vv_opcode voa(voap) ^= vo_if &
      33                      vv_opcode voa(voap) ^= vo_ifnot) quit until;
      34                  i = vv_chain voa(voap);   $ point to next.
      35                  if  (i = 0) quit until;  $ must not be last op.
      36                  if  (vv_opcode voa(i) ^= vo_goto) quit until;
      37
      38                  $   scan and see if any labels following are
      39                  $   the target of the if/ifnot.
      40                  j = vv_chain voa(i);  $ start at next operation.
      41                  while  j ^= 0 & vv_opcode voa(j) = vo_lab;
      42                      $   check destination against this label.
      43                      if  vv_inp2 voa(voap) = vv_inp1 voa(j) then
      44                          $   reduce count of original label.
      45                          ll_count lablist(vv_inp2 voa(voap)) =
      46                              ll_count lablist(vv_inp2 voa(voap)) - 1;
      47                          $   next, switch opcode to inverse operation.
      48                          vv_opcode voa(voap) = (vo_if+vo_ifnot) -
      49                              vv_opcode voa(voap);
      50                          $   change target label.
      51                          vv_inp2 voa(voap) = vv_inp1 voa(i);
      52                          $   finally, rechain around -goto-.
      53                          vv_chain voa(voap) = vv_chain voa(i);
      54                          modfl = yes;  $ show a change was made.
      55                          quit until;
      56                          end if;
      57
      58                      j = vv_chain voa(j);  $ get next in chain.
      59                      end while;
      60                  end until;
      61
      62
      63              $   see what the target of an -if-, -ifnot-, or
      64              $   -goto- is pointing to and update if possible.
      65              $   note that do not bother to update -goby-
      66              $   operations because the payoff would be small.
      67              until  yes;  $ exit if updated or cannot update.
      68                  $   see if this is an eligable op-code.
      69                  if  vv_opcode voa(voap) = vo_goto !
      70                      vv_opcode voa(voap) = vo_if !
      71                      vv_opcode voa(voap) = vo_ifnot then  $ this is ok.
      72
      73                      $   first, get target label.
      74                      if  vv_opcode voa(voap) = vo_goto
      75                          then    lab = vv_inp1 voa(voap);
      76                          else    lab = vv_inp2 voa(voap);   end if;
      77
      78                      $   get defining point of label.
      79                      i = ll_def lablist(lab);
      80                      if  (i = 0) quit until;  $ undefined or return.
      81                      targsp = 0;  $ show no branch targets yet.
      82
      83 /labloop/            $ follow target.
      84
      85                      $   first see if target is simply the next
      86                      $   statement.
      87                      j = vv_chain voa(voap);  $ point to next.
      88                      while  j ^= 0 & vv_opcode voa(j) = vo_lab;
      89                          if  j = i then  $ it is null branch.
dsl   11                              if  (vv_opcode voa(voap) ^= vo_goto)
dsl   12                                  quit while;
      90                              $   first, decrease label count.
      91                              ll_count lablist(lab) =
      92                                  ll_count lablist(lab) - 1;
      93                              $   unchain the -goto-.
      94                              if  voap = voahead then  $ see if top.
      95                                  voahead = vv_chain voa(voap);
      96                              else  $ not start of chain.
      97                                  vv_chain voa(voalast) =   $ rechain.
      98                                      vv_chain voa(voap);
      99                                  end if;
     100
     101                              modfl = yes;  $ show change made.
     102                              voap = vv_chain voa(voap);  $ next.
     103                              cont while voap;  $ around again.
     104                              end if;
     105
     106                          j = vv_chain voa(j);  $ get next.
     107                          end while;
     108
     109                      $   check for the case where a -goto- is the
     110                      $   destination.  first skip any labels at the
     111                      $   branch point.
     112                      while  i ^= 0 & vv_opcode voa(i) = vo_lab;
     113                          j = i;  $ save last value.
     114                          i = vv_chain voa(i);  $ point to next.
     115                          end while;
     116
     117                      if  i = 0 then  $ must process this -goto-.
     118                          i = j;  $ back to last label.
     119                          go to labproc;  $ go and process.
     120                          end if;
     121
     122                      $   do check of destination.
     123                      if  vv_opcode voa(i) = vo_goto then  $ special.
     124                          $   will want to change this to a
     125                          $   branch to the target so see what the
     126                          $   target is.
     127                          j = ll_def lablist(vv_inp1 voa(i));
     128
     129                          $   if this is undefined, go process
     130                          $   by getting label from -goto-.
     131                          if  (j = 0) go to labproc;
     132
     133                          i = j;  $ point to destination.
     134
     135                          $   must verify that never branched
     136                          $   to this label in this search.  this
     137                          $   could be caused by an infinite loop.
     138                          do  j = 1 to targsp;   $ scan targets.
     139                              if  targs(j) = i then  $ duplicate.
     140                                  error('infinite loop found near '
     141                                      !! 'label', j);
     142                                  quit until;  $ skip this.
     143                                  end if;
     144                              end do;
     145
     146                          $   insert into target array.
     147                          countup(targsp, 20, 'targs');  $ increment.
     148                          targs(targsp) = i;  $ insert label into array.
     149                          go to labloop;  $ take 'branch'.
     150                          end if;
     151
     152                      $   look backwards for the next label in the
     153                      $   chain to use as a destination.
     154                      j = i;  $ point to an operation in the chain.
     155                      do  i = i to 1 by -1;  $ scan backwards.
     156                          if  (vv_opb voa(i) = no) cont do;  $ not op.
     157                          if  (vv_chain voa(i) ^= j) cont do;
     158                          j = i;  $ show this is in chain.
     159                          if  (vv_opcode voa(i) = vo_lab) quit do;
     160                          end do;
     161
     162 /labproc/            $   update the target to point to here.
     163                      if  (i = 0) call aermey(2);  $ this is error.
     164
     165                      $   check if target changed.  if so, update.
     166                      if  vv_inp1 voa(i) ^= lab then  $ it did.
     167                          modfl = yes;  $ show an update done.
     168                          ll_count lablist(lab)=ll_count lablist(lab)-1;
     169                          ll_count lablist(vv_inp1 voa(i)) =
     170                              ll_count lablist(vv_inp1 voa(i)) + 1;
     171
     172                          $   do update of target.
     173                          if  vv_opcode voa(voap) = vo_goto
     174                              then   vv_inp1 voa(voap) = vv_inp1 voa(i);
     175                              else   vv_inp2 voa(voap) = vv_inp1 voa(i);
     176                              end if;
     177                          end if;
     178                      end if;
     179                  end until;
     180
     181
     182              $   see if the current operation is an unreferenced
     183              $   label.  delete it if so.
     184              if  vv_opcode voa(voap) = vo_lab then  $ it is a label.
     185                  if  ll_count lablist(vv_inp1 voa(voap)) = 0 then
     186                      $   this label is unreferenced.  so unchain it.
     187                      modfl = yes;   $ show a change made.
     188                      $   unchain.
     189                      if  voap = voahead then  $ this is top.
     190                          voahead = vv_chain voa(voap);  $ set new top.
     191                      else    $ this is not top.
     192                          vv_chain voa(voalast) = vv_chain voa(voap);
     193                          end if;
     194
dsp   39                      i = voap;  $ keep pointer to label being deleted.
     195                      voap = vv_chain voa(voap);  $ point to next.
dsp   40                      $   clear chain so won't be pickup up as valid
dsp   41                      $   label later.
dsp   42                      vv_chain voa(i) = 0;  $ clear chain.
     196                      cont while;  $ go around again.
     197                      end if;
     198                  end if;
     199
     200              $   see if this is an unconditional -goto- (or -goby-)
     201              $   which is followed by something other than a label.
     202              $   if so, delete text in between.
     203              if  vv_opcode voa(voap) = vo_goto !   $ if -goto-.
     204                  vv_opcode voa(voap) = vo_goby then  $ or -goby-.
     205                  i = vv_chain voa(voap);  $ point to next.
     206                  while  i;  $ loop until hit end.
     207                      if  (vv_opcode voa(i) = vo_lab) quit while;
     208
     209                      $   -i- points to unreferenced operation.
     210                      $   will delete it by rechaining so decrement
     211                      $   any label references of the deleted operation.
     212                      call labcount(i, -1);  $ decrement counts.
     213                      i = vv_chain voa(i);  $ point to next.
     214                      modfl = yes;  $ show a modification was made.
     215                      end while;
     216
     217                  $   rechain.
     218                  vv_chain voa(voap) = i;  $ this may be same as before.
     219                  end if;
     220
     221
     222
     223              $   finally, go to next operation in -voa-.
     224              voalast = voap;  $ save pointer to last.
     225              voap = vv_chain voa(voap);  $ point to next.
     226              end while voap;
     227          end until modfl;
     228
     229
     230      $   just do a final check on the -return-.  see if the last
     231      $   operation is a -goto- to the return label.  if it is, then
     232      $   can just remove it from the chain.
     233      if  vv_opcode voa(voalast) = vo_goto &    $ it is -goto-.
     234          vv_inp1 voa(voalast) = returnlab then  $ it is this case.
     235
     236          $   scan backwards for the last operation before this one.
     237          do  i = voalast to 1 by -1;  $ go back.
     238              if  (vv_opb voa(i) = no) cont do;  $ skip data.
     239              if  vv_chain voa(i) = voalast then  $ this is the one.
     240                  voalast = i;  $ show this is last.
     241                  vv_chain voa(i) = 0;  $ show in -voa-.
     242                  quit do;
     243                  end if;
     244              end do;
     245          end if;
     246
     247      $   if count of return label is zero, no return is done
     248      $   from the routine so can clear -returnlab- to suppress
     249      $   unneeded code.
     250      if  (ll_count lablist(returnlab) = 0) returnlab = 0;
     251
     252      $   finally, clear -lablist- again.
     253      do  i = 1 to lablistptr;  lablist(i) = 0;  end do;
     254
     255      end subr labfixup;
       1 .=member labcnt
       2 ..labopt
       3 .+labopt.  $ used only for label optimizations.
       4      subr labcount(voap, inc);  $ count usage of label.
       5      $   this routine is passed a -voa- pointer and an increment.
       6      $   it sees if there are any labels referenced (not defined)
       7      $   in the operation and increments their counts by the increment
       8      $   that it is passed (usually +1 or -1).
       9      size  voap(ps);     $ pointer to operation.
      10      size  inc(ws);      $ increment.
      11      size  i(ps);        $ loop variable.
      12      size  lab(ps);      $ label to decrement.
      13
      14      lab = 0;  $ show no label found yet.
      15
      16      $   see what type of operation this is.
      17      if  vv_opcode voa(voap) = vo_goto then  $ this references label.
      18          lab = vv_inp1 voa(voap);    $ get the label.
      19      elseif  vv_opcode voa(voap) = vo_if !  $ if -if-.
      20              vv_opcode voa(voap) = vo_ifnot then  $ or -ifnot-.
      21              lab = vv_inp2 voa(voap);  $ label is here.
      22      elseif  vv_opcode voa(voap) = vo_goby then  $ indexed -goto-.
      23          $   this is handled via a loop.
      24          do  i = vv_argbeg voa(voap) to    $ loop over -xarg- entries.
      25              vv_argbeg voa(voap) + vv_arglen voa(voap) - 1;
      26              ll_count lablist(xa_voa xarg(i)) =   $ change count.
      27                  ll_count lablist(xa_voa xarg(i)) + inc;
      28              end do;
      29          end if;
      30
      31      $   if a label was found, change its count.
      32      if  (lab)  ll_count lablist(lab) = ll_count lablist(lab) + inc;
      33
      34      end subr labcount;
       1 .=member getprm
       2 ..labopt
       3      subr getperm(min);  $ assign permanent register.
       4      $   this routine scans the -voa- to find the best value
       5      $   to permanently assign to a register.
       6      size  min(ps);          $ minimum count needed to assign.
       7      size  musage(ps);       $ highest usage so far.
       8      size  i(ps);            $ index.
       9      size  usage(ws);        $ usage of scanned variable.
      10
      11      musage = min;   $ show 'best' so far.
      12      voaep = 0;   $ show none assigned.
      13      do  i = 1 to voaptr;  $ scan -voa-.
      14          if  (vv_opb voa(i)) cont do;  $ skip operations.
      15          if  (vv_ppdata voa(i) = no) cont do;  $ skip if not eligible.
      16          usage = vv_varnuse voa(i);   $ get usage count.
      17          if  (vv_mblk voa(i) >= bl_global)  $ must decrement.
      18              usage = usage - numcalls*2;  $ allow for number of calls.
      19
      20          $   see if this is best so far.
      21          if  (usage < musage) cont do;  $ worse.
      22          $   else, show this variable is 'better'.
      23          voaep = i; musage = usage;
      24          end do;
      25
      26 .+trace.
      27      if  trace_d then   $ print last action.
      28          tintl('getperm, voaep', voaep) endl
      29          end if;
      30 ..trace
      31
      32      end subr getperm;
       1 .=member asmprog
       2      subr asmprog;  $ scan -voa- operations.
       3      $   this is the highest-level routine in -asm- for
       4      $   generating the code for a routine.  it is responsible
       5      $   for looping over the -voa- and calling -emitdop-, the
       6      $   next lower-level routine, to issue each -voa- operation
       7      $   to be processed.  this routine is largely table-driven
       8      $   and machine-independent.
       9
      10      size  voptab(ws);       $ -voa- operation table.
      11      dims  voptab(num_vo);   $ number of operations.
      12
      13      $   fields in -voptab-.
      14
      15      +*  vt_ign     = .f. 01, 1, **  $ new setting for -ignorevoa-
      16      +*  vt_storall = .f. 02, 1, **  $ 'must do -storall-'
      17      +*  vt_xargs   = .f. 03, 1, **  $ 'operation has extra args'
      18      +*  vt_isout   = .f. 04, 1, **  $ 'operation has output'
      19      +*  vt_inv     = .f. 05, 1, **  $ 'invert operands'
      20      +*  vt_nargs   = .f. 06, 3, **  $ number of arguments
      21      +*  vt_dop     = .f. 09, 8, **  $ operation to issue
      22      +*  vt_kind    = .f. 17, 5, **  $ operation types
      23
      24      $   types for -voa- opcodes.
      25      +*  vk_data   = 01 **    +*  vk_lab    = 09 **
      26      +*  vk_ext    = 02 **    +*  vk_mwbin  = 10 **
      27      +*  vk_fasin  = 03 **    +*  vk_sasin  = 11 **
      28      +*  vk_fcall  = 04 **    +*  vk_scall  = 12 **
      29      +*  vk_goby   = 05 **    +*  vk_sext   = 13 **
      30      +*  vk_goto   = 06 **    +*  vk_simp   = 14 **
      31      +*  vk_if     = 07 **    +*  vk_xfasin = 15 **
      32      +*  vk_io     = 08 **
      33
      34      +*  num_vk = 15 **  $ number of -voa- operation types
      35
      36      $   macro to initialize -voptab-.
      37
      38      +*  vop(num, typ, dop, nargs, inv, out, xarg, stor, ign) =
      39          voptab(num) = typ*4b'10000'+dop*4b'100'+nargs*4b'20'+
      40              inv*1b'10000'+out*1b'1000'+xarg*1b'100'+stor*1b'10'+ign **
      41
      42      data    $   initialize table.
      43
      44 $     vop         kind       dop     args inv out  xarg stor  ign
      45 $     ---         ----       ---     ---- --- ---  ---- ----  ---
      46
      47  vop(vo_add,    vk_simp,   do_add,    2,  no, yes,  no,  no,  no):
      48  vop(vo_sub,    vk_simp,   do_sub,    2,  no, yes,  no,  no,  no):
      49  vop(vo_gt,     vk_simp,   do_lt,     2, yes, yes,  no,  no,  no):
      50  vop(vo_lt,     vk_simp,   do_lt,     2,  no, yes,  no,  no,  no):
      51  vop(vo_ge,     vk_simp,   do_ge,     2,  no, yes,  no,  no,  no):
      52  vop(vo_le,     vk_simp,   do_ge,     2, yes, yes,  no,  no,  no):
      53  vop(vo_eq,     vk_simp,   do_eq,     2,  no, yes,  no,  no,  no):
      54  vop(vo_ne,     vk_simp,   do_ne,     2,  no, yes,  no,  no,  no):
      55  vop(vo_mul,    vk_simp,   do_mul,    2,  no, yes,  no,  no,  no):
      56  vop(vo_div,    vk_simp,   do_div,    2,  no, yes,  no,  no,  no):
      57  vop(vo_or,     vk_simp,   do_or,     2,  no, yes,  no,  no,  no):
      58  vop(vo_and,    vk_simp,   do_and,    2,  no, yes,  no,  no,  no):
      59  vop(vo_exor,   vk_simp,   do_exor,   2,  no, yes,  no,  no,  no):
      60  vop(vo_nb,     vk_simp,   do_nb,     1,  no, yes,  no,  no,  no):
      61  vop(vo_fb,     vk_simp,   do_fb,     1,  no, yes,  no,  no,  no):
      62  vop(vo_not,    vk_simp,   do_not,    1,  no, yes,  no,  no,  no):
      63  vop(vo_fcall,  vk_fcall,  do_fcall,  0,  no, yes, yes,  no,  no):
      64  vop(vo_scall,  vk_scall,  do_scall,  0,  no,  no, yes, yes,  no):
      65  vop(vo_asin,   vk_simp,   do_asin,   2,  no,  no,  no,  no,  no):
      66  vop(vo_data,   vk_data,   0,         0,  no,  no,  no,  no,  no):
      67  vop(vo_fasin,  vk_fasin,  do_fasin,  4,  no,  no,  no,  no,  no):
      68  vop(vo_io,     vk_io,     do_scall,  2,  no,  no,  no, yes,  no):
      69  vop(vo_return, vk_simp,   do_return, 0,  no,  no,  no, yes, yes):
      70  vop(vo_fext,   vk_ext,    do_fext,   3,  no, yes,  no,  no,  no):
      71  vop(vo_if,     vk_if,     do_if,     1,  no,  no,  no, yes,  no):
      72  vop(vo_lab,    vk_lab,    0,         0,  no,  no,  no, yes,  no):
      73  vop(vo_goto,   vk_goto,   do_goto,   0,  no,  no,  no, yes, yes):
      74  vop(vo_goby,   vk_goby,   do_goby,   1,  no,  no,  no, yes, yes):
      75  vop(vo_xload,  vk_simp,   do_xload,  2,  no, yes,  no,  no,  no):
      76  vop(vo_xasin,  vk_simp,   do_xasin,  3,  no,  no,  no,  no,  no):
      77  vop(vo_xfasin, vk_xfasin, do_xfasin, 4,  no,  no, yes,  no,  no):
      78  vop(vo_ifnot,  vk_if,     do_ifnot,  1,  no,  no,  no, yes,  no):
      79  vop(vo_ccat,   vk_mwbin,  do_scall,  2,  no, yes,  no,  no,  no):
      80  vop(vo_in,     vk_mwbin,  do_fcall,  2,  no, yes,  no,  no,  no):
      81  vop(vo_eext,   vk_ext,    do_eext,   3,  no, yes,  no,  no,  no):
      82  vop(vo_sext,   vk_sext,   do_scall,  3,  no, yes,  no,  no,  no):
      83  vop(vo_easin,  vk_fasin,  do_easin,  4,  no,  no,  no,  no,  no):
      84  vop(vo_sasin,  vk_sasin,  do_scall,  4,  no,  no,  no,  no,  no):
      85  vop(vo_xeasin, vk_xfasin, do_xeasin, 4,  no,  no, yes,  no,  no):
      86  vop(vo_xsasin, vk_simp,   do_xsasin, 4,  no,  no, yes,  no,  no):
      87  vop(vo_radd,   vk_simp,   do_radd,   2,  no, yes,  no,  no,  no):
      88  vop(vo_rsub,   vk_simp,   do_rsub,   2,  no, yes,  no,  no,  no):
      89  vop(vo_rgt,    vk_simp,   do_rlt,    2, yes, yes,  no,  no,  no):
      90  vop(vo_rlt,    vk_simp,   do_rlt,    2,  no, yes,  no,  no,  no):
      91  vop(vo_rge,    vk_simp,   do_rge,    2,  no, yes,  no,  no,  no):
      92  vop(vo_rle,    vk_simp,   do_rge,    2, yes, yes,  no,  no,  no):
      93  vop(vo_req,    vk_simp,   do_req,    2,  no, yes,  no,  no,  no):
      94  vop(vo_rne,    vk_simp,   do_rne,    2,  no, yes,  no,  no,  no):
      95  vop(vo_rmul,   vk_simp,   do_rmul,   2,  no, yes,  no,  no,  no):
      96  vop(vo_rdiv,   vk_simp,   do_rdiv,   2,  no, yes,  no,  no,  no):
      97  vop(vo_rusub,  vk_simp,   do_rusub,  1,  no, yes,  no,  no,  no):
      98  vop(vo_abs,    vk_simp,   do_abs,    1,  no, yes,  no,  no,  no):
dsj   48  vop(vo_float,  vk_simp,   do_float,  1,  no, yes,  no,  no,  no):
dsj   49  vop(vo_ifix,   vk_simp,   do_ifix,   1,  no, yes,  no,  no,  no):
dsj   50  vop(vo_int,    vk_simp,   do_ifix,   1,  no, yes,  no,  no,  no):
dsj   51  vop(vo_aint,   vk_simp,   do_aint,   1,  no, yes,  no,  no,  no):
dsj   52  vop(vo_amod,   vk_simp,   do_amod,   2,  no, yes,  no,  no,  no):
      99  vop(vo_iabs,   vk_simp,   do_iabs,   1,  no, yes,  no,  no,  no):
     100  vop(vo_mod,    vk_simp,   do_mod,    2,  no, yes,  no,  no,  no):
     101  vop(vo_sign,   vk_simp,   do_sign,   2,  no, yes,  no,  no,  no):
     102  vop(vo_isign,  vk_simp,   do_isign,  2,  no, yes,  no,  no,  no):
     103  vop(vo_dim,    vk_simp,   do_dim,    2,  no, yes,  no,  no,  no):
     104  vop(vo_idim,   vk_simp,   do_idim,   2,  no, yes,  no,  no,  no):
     105  vop(vo_seq,    vk_simp,   do_seq,    2,  no, yes,  no,  no,  no):
     106  vop(vo_sne,    vk_simp,   do_sne,    2,  no, yes,  no,  no,  no);
     107
     108      macdrop(vop)
     109
     110      size  inv(1);           $ on if operands should be inverted
     111      size  xargs(1);         $ on if operation has values in -xarg-
     112      size  storflag(1);      $ on if must do 'storall' for op
     113      size  opkind(ps);       $ operation type
     114      size  ignorevoa(1);     $ flag to ignore dead -voa- ops
     115      size  t1(ps), t2(ps);   $ temporaries
     116      size  i(ps), j(ps);     $ loop variables.
     117
     118      size  uio_routs(.sds. 7);   $ routine names for unformatted i/o.
     119      dims  uio_routs(4);         $ var/array and input/output
vaxa 167 .+t10    data  uio_routs = 'rdlv$i', 'rdla$i',
vaxa 168 .+t10                      'wtlv$i', 'wtla$i';
vaxa 169 .+t32    data  uio_routs = 'rdlv$io', 'rdla$io',
vaxa 170 .+t32                      'wtlv$io', 'wtla$io';
     122
     123
     124      ignorevoa = no;  $ initially don't ignore -voa- ops.
     125
     126      $   begin loop over -voa-.
     127      voaep = voahead; reissuedop = yes;  $ set initial status.
     128      while  yes;   $ loop while more in chain.
     129
     130          $   see if should reissue last operation or if should
     131          $   get a new one.
     132          if  reissuedop then  $ must re-issue.
     133              reissuedop = no;  $ clear flag.
     134              vopcode = vv_opcode voa(voaep);  $ get -voa- op. code.
     135          else    $ get new operation.
     136              voaep = vv_chain voa(voaep);  $ step to next.
     137              if  (voaep = 0) quit while;  $ exit at end of chain.
     138              vopcode = vv_opcode voa(voaep);  $ get -voa- op. code.
     139              $   see if dead operation.
     140              if  (vopcode ^= vo_lab & ignorevoa) cont while;  $ skip.
     141              end if;
     142
     143          $   have a -voa- entry must process.  extract
     144          $   parameters for this opcode from -voptab-.
     145          dopnargs = vt_nargs voptab(vopcode);  $ number of args.
     146          inv = vt_inv voptab(vopcode);  $ 'invert arguments'
     147          dophasout = vt_isout voptab(vopcode);  $ 'has output'
     148          dopcode = vt_dop voptab(vopcode);  $ operation to issue
     149          xargs = vt_xargs voptab(vopcode);  $ 'uses -xarg-'
     150          storflag = vt_storall voptab(vopcode);  $ 'do -storall-'
     151          opkind = vt_kind voptab(vopcode);  $ operation type
     152          ignorevoa = vt_ign voptab(vopcode);  $ new setting
     153
     154 .+trace.    $ generate trace code.
     155          if  trace_any then  $ if any trace, give -voa- pointer.
     156              tintl('voaep', voaep)
     157              if  trace_v then  $ print operations.
     158                  tintl('op', vopcode) tintl('ign', ignorevoa)
     159                  tintl('kind', opkind) tintl('inv', inv)
     160                  end if;
     161              endl
     162              end if;
     163 ..trace
     164      $   if this is an operation with an output,  but the lastuse
     165      $   field of the operatin is zero, it means that the output
     166      $   will never be used.  thus there is no need to issue the
     167      $   operation.  operations of this type occur mostly in the
     168      $   'a(i) to a(j)' construct in the formatted and unformatted
     169      $   io statements.
     170      if  (dophasout & vv_lastuse voa(voaep) = 0)  cont while;
     171
     172      $   start processing. first, see if must store regs.
     173      if  (storflag)  call storall;  $ if need to store regs.
     174
     175      $   get arguments.
     176      go to n(dopnargs) in 0 to 4;  $ select number to get.
     177
     178 /n(4)/   $ four arguments.
     179          assign(doplr, va_inp4);  $ get fourth argument.
     180 /n(3)/   $ three arguments
     181          assign(dopkr, va_inp3);  $ get third argument.
     182 /n(2)/   $ two arguments
     183          assign(dopjr, va_inp2);  $ get second argument.
     184 /n(1)/   $ one argument
     185          assign(dopir, va_inp1);  $ get first argument.
     186 /n(0)/   $ no arguments - fall through to next step.
     187
     188          $   invert first & second args, if needed.
     189          if  inv then  t1 = dopjr; dopjr = dopir; dopir = t1; end if;
     190          $   get output, if it exists.
     191          if  dophasout then  assign(dopor, va_oup); end if;
     192          $   get extra arguments (-xarg-), if they exist.
     193          if  xargs then  $ they do exist.
     194              dopnx = vv_arglen voa(voaep);  $ get number of arguments.
     195              do  t1 = 1 to dopnx;  $ process each argument.
     196                  assign(dopxr(t1), va_xarg+t1)
     197                  end do;
     198          else
     199              dopnx = 0;  $ no arguments present.
     200              end if;
     201
     202          $   branch on opcode type.
     203          go to l(opkind) in 1 to num_vk;
     204
     205 /l(vk_simp)/
     206          $   simple operation - issue it.
     207          call emitdop;
     208          cont while;
     209
     210 /l(vk_scall)/
     211          $   subroutine call.
vaxa 171 .+t10    sdlname(dopsname, vv_naym voa(voaep));  $ get (long) name to c
vaxa 172 .+t32    sdsname(dopsname, vv_naym voa(voaep));  $ get name to call.
     213
     214          $   subroutine call ends basic block if -vv_seblk- flag set.
     215          if  vv_seblk voa(voaep) then  $ want to end block.
     216              calldropgl = yes;  $ indicate call should drop globals.
     217          else    $ indicate it shouldn't drop parameters.
     218              callnodrop = yes; $ set special case flag.
     219              end if;
     220
     221          call emitdop;  $ issue call.
     222
     223          if  (vv_seblk voa(voaep)) call endblock;  $ end block.
     224
     225          cont while;
     226
     227 /l(vk_fcall)/
     228          $   function call.
     229          sdsname(dopsname, vv_naym voa(voaep))  $ get name to call.
     230          callnodrop = yes;  $ function cant change parameters.
dsk  289          calldropgl = fag_opt;  $ set whether or not to drop globals.
     231          call emitdop;  $ issue call
     232          cont while;
     233
     234 /l(vk_data)/
     235          $   -data- statement.  in this case call a special
     236          $   routine, -asmdata-, to process this -voa- entry.
     237          call asmdata;
     238          cont while;
     239
     240 /l(vk_fasin)/
     241          $   .f. field assignment.
     242          call emitdop;  $ issue it, or old code.
     243          cont while;
     244
     245 /l(vk_io)/
     246          $   unformatted io.  this is to be assembled as a subroutine
     247          $   call.  generate the parameter list and issue a
     248          $   subroutine call operation.
     249          dopxr(1) = dopjr;  $ first is i/o item.
     250          assignconst(dopxr(2), syze(dopjr))  $ second is size.
     251          if  vv_inp3 voa(voaep)  then  $ if array slice.
     252              dopnx = 4;  $ show four parameters.
     253              assign(dopxr(3), va_inp3)  $ third is from inp3.
     254              if  vv_arglen voa(voaep)  then  $ get hi value.
     255                  assign(dopxr(4), va_xarg+1)  $ get fourth value.
     256              else  $ if hi = lo.
     257                  dopxr(4) = dopxr(3);  $ copy value.
     258                  using(dopxr(3));  $ show additional use.
     259                  end if;
     260          else  $ this is simple variable case.
     261              dopnx = 2;  $ set short parameter list length.
     262              end if;
     263          $   select routine to call depending on whether this is
     264          $   input or output and whether this is slice or not.
     265          dopsname = uio_routs(2*(vv_oup voa(voaep)) + (dopnx>2) + 1);
     266          dopnargs = 0; dophasout = (dopcode = do_fcall);  $ reset.
     267          callnodrop = (vv_oup voa(voaep) > 0);
dse   14          kill(dopir);
     268          call emitdop;  $ issue call to i/o routine.
     270          $   if input call, this ends block.
     271          if  (vv_oup voa(voaep) = 0) call endblock;
     272          cont while;
     273
     274 /l(vk_ext)/
     275          $   .f. extract.
     276          call emitdop;  $ issue operation.
     277          cont while;
     278
     279 /l(vk_if)/
     280          $   -if- or -ifnot- operation.  get label number and issue.
     281          dopjr = vv_inp2 voa(voaep);  $ label is in -vv_inp2-.
     282          call emitdop;
     283          cont while;
     284
     285 /l(vk_lab)/
     286          $   label.  end basic block and define label.
     287          call endblock;
     288          labdef(vv_inp1 voa(voaep), yes)  $ label is in -vv_inp1-.
     289          cont while;
     290
     291 /l(vk_goto)/
     292          $   goto operation.  get label number and issue.
     293          dopir = vv_inp1 voa(voaep);  $ label is in -vv_inp1-.
     294          call emitdop;  $ issue operation.
     295          cont while;
     296
     297 /l(vk_goby)/
     298          $   indexed -goto-. copy labels and issue.
     299          dopnx = vv_arglen voa(voaep);  $ get no. of labels.
     300          t1 = vv_argbeg voa(voaep)-1;  $ save time in loop.
     301          do   t2 = 1 to dopnx;  $ move in each label.
     302              dopxr(t2) = xa_voa xarg(t1+t2);  $ copy from -xarg-.
     303              end do;
     304          call emitdop;  $ issue operation.
     305          cont while;
     306
     307 /l(vk_xfasin)/
     308          $   .f. x, y, a(i) op, indexed extract.
     309          call emitdop;  $ issue operation.
     310          cont while;
     311
     312 /l(vk_mwbin)/
     313          $   .cc. or .in. operation.  process as subroutine call.
     314          dopsname = longname(vopcode);  $ get routine name.
     315          dopnx = 3;  $ this call has three parameters.
     316          dopxr(1) = dopir; dopxr(2) = dopjr;  $ first two are inputs.
     317          dopxr(3) = dopor; $ third parameter is output.
     318          if  (vopcode = vo_in) dopnx = 2;  $ .in. is function.
     319          dopnargs = 0; dophasout = (dopcode = do_fcall);  $ reset.
     320          call emitdop; $ issue op.
     321          cont while;
     322
     323 /l(vk_sasin)/
     324          $   .s. assignment operation.  process as subroutine call.
     325          dopsname = longname(vo_sasin);  $ get routine name.
     326          dopnx = 4;  $ set to four parameters.
     327          dopxr(1) = dopkr;  $ first argument is position.
     328          dopxr(2) = doplr;  $ second is length.
     329          dopxr(3) = dopjr;  $ third is source.
     330          dopxr(4) = dopir;  $ and fourth is target.
     331          dopnargs = 0; dophasout = (dopcode = do_fcall);  $ reset.
     332          call emitdop;  $ issue call.
     333          cont while;
     334
     335 /l(vk_sext)/
     336          $   .s. extraction.  process as subroutine call.
     337          dopsname = longname(vo_sext);  $ get routine name.
dsh   11          dopnx = 4;  $ call has four parameters.
     339          dopxr(1) = dopir;  $ first is character position.
     340          dopxr(2) = dopjr;  $ second is length.
     341          dopxr(3) = dopkr;  $ third is source.
     342          dopxr(4) = dopor;  $ and fourth is output.
     344          dopnargs = 0; dophasout = (dopcode = do_fcall);  $ reset.
     345          call emitdop;  $ issue operation.
     346          cont while;
     347
     348          end while;  $ end of main -voa- loop.
     349
     350
     351      macdrop(vt_ign)         macdrop(vt_storall)
     352      macdrop(vt_xarg)        macdrop(vt_isout)
     353      macdrop(vt_inv)         macdrop(vt_nargs)
     354      macdrop(vt_dop)         macdrop(vt_kind)
     355
     356      macdrop(vk_data)        macdrop(vk_easin)
     357      macdrop(vk_simp)        macdrop(vk_ext)
     358      macdrop(vk_fasin)       macdrop(vk_fcall)
     359      macdrop(vk_goby)        macdrop(vk_goto)
     360      macdrop(vk_if)          macdrop(vk_io)
     361      macdrop(vk_lab)         macdrop(vk_mwbin)
     362      macdrop(vk_sasin)       macdrop(vk_scall)
     363      macdrop(vk_sext)        macdrop(vk_xeasin)
     364      macdrop(vk_sasin)       macdrop(num_vk)
     365
     366      end subr asmprog;
       1 .=member emitdop
       2      subr emitdop;   $ process deferred-level operations.
       3      $   this routine processes each 'deferred' operation sent
       4      $   by -asmprog-.  the attributes of each operation are
       5      $   kept in the table -doptab-.  -emitdop- checks to see
       6      $   if deferring mode is enabled (compilation option) and
       7      $   whether the operation being processed can be deferred.
       8      $   if so, the operation will be deferred until its operands
       9      $   are needed.  next, unless it is flagged as permissable
      10      $   for an operand of the current operation to be deferred,
      11      $   the current operation is reissueed until the operand at
      12      $   fault is evaluated.
      13      $
      14      $   if the processor for any operation find that an operand
      15      $   has been deferred and the operation that yields the operand
      16      $   is not one the enables a special case, that processor will
      17      $   branch to label -reissue- to indicate that the current
      18      $   operation must be reissueed until the operand can be
      19      $   evaluated.  the operation to execute is passed in the
      20      $   variable -dophold-.  note that the processor must
      21      $   determine if it must force evaluation of any operands
      22      $   before it does 'anything else' that affects status
      23      $   of the compilation.
      24
      25      size  doptab(ws);           $ deferred operation table.
      26      dims  doptab(num_do);       $ length of table.
      27
      28      $   fields in -doptab-.
      29
      30      +*  dt_dx      = .f. 01, 1, **   $ '-xargs- can be deferred'
      31      +*  dt_do      = .f. 02, 1, **   $ 'output can be deferred'
      32      +*  dt_d4      = .f. 03, 1, **   $ 'input four can be deferred'
      33      +*  dt_d3      = .f. 04, 1, **   $ 'input three can be deferred'
      34      +*  dt_d2      = .f. 05, 1, **   $ 'input 2 can be deferred'
      35      +*  dt_d1      = .f. 06, 1, **   $ 'input 1 can be deferred'
      36      +*  dt_defer   = .f. 07, 1, **   $ 'operation should be deferrred'
      37      +*  dt_spcasin = .f. 08, 1, **   $ 'operation is special cased'
      38      +*  dt_type    = .f. 09, 8, **   $ operation type
      39      +*  dt_aop     = .f. 17, 8, **   $ operation to issue
      40
      41      $   deferred operation types.
      42
      43 .+eab.
      44      +*  dk_asin   = 01 **    +*  dk_simp0  = 14 **
      45      +*  dk_bool   = 02 **    +*  dk_simp1  = 15 **
      46      +*  dk_casin  = 03 **    +*  dk_simp2  = 16 **
      47      +*  dk_cext   = 04 **    +*  dk_xasin  = 17 **
      48      $   casin and cext should never occur for s10, but keep codes now.
      49      +*  dk_easin  = 05 **    +*  dk_xeasin = 18 **
      50      +*  dk_eext   = 06 **    +*  dk_xload  = 19 **
      51      +*  dk_fasin  = 07 **    +*  dk_xsasin = 20 **
      52      +*  dk_fcall  = 08 **    +*  dk_mod    = 21 **
      53      +*  dk_fext   = 09 **    +*  dk_dim    = 22 **
      54      +*  dk_fnb    = 10 **    +*  dk_return = 23 **
      55      +*  dk_goto   = 11 **    +*  dk_seq    = 24 **
      56      +*  dk_if     = 12 **    +*  dk_goby   = 25 **
      57      +*  dk_not    = 13 **    +*  dk_comp   = 26 **
      58
      59      +*  num_dk = 26 **      $ number of types.
      60 .-eab.
      61 .=zzyorg a
      62
      63      defc(dk_asin)
      64      defc(dk_bool)
      65      defc(dk_easin)
      66      defc(dk_eext)
      67      defc(dk_fasin)
      68      defc(dk_fcall)
      69      defc(dk_fext)
      70      defc(dk_goto)
      71      defc(dk_if)
      72      defc(dk_not)
      73      defc(dk_simp0)
      74      defc(dk_simp1)
      75      defc(dk_simp2)
      76      defc(dk_mod)
      77      defc(dk_xasin)
      78      defc(dk_xeasin)
      79      defc(dk_xload)
      80      defc(dk_xsasin)
      81      defc(dk_return)
      82      defc(dk_seq)
      83      defc(dk_dim)
      84      defc(dk_goby)
      85      defc(dk_comp)
      86
      87      +*  num_dk = dk_comp **
      88 ..eab
      89
      90      $   macro to initialize -doptab-.
      91      +*  dop(num, df, of, as, typ, aop) =
      92          doptab(num) = aop*4b'10000'+typ*4b'100'+
      93              as*4b'80' + df*1b'1000000' + of **
      94
      95      data        $ build table.
      96
      97
      98 $      dop      def     1234ox   as    type       aop
      99 $      ---      ---     ------   --    ----       ---
     100
     101  dop(do_add,    yes, 1b'001100', yes, dk_simp2,  ao_iad):
     102  dop(do_sub,    yes, 1b'001100', yes, dk_simp2,  ao_isu):
     103  dop(do_lt,     yes, 1b'111100',  no, dk_comp,   ao_ilt):
     104  dop(do_ge,     yes, 1b'111100',  no, dk_comp,   ao_ige):
     105  dop(do_eq,     yes, 1b'111100',  no, dk_comp,   ao_ieq):
     106  dop(do_ne,     yes, 1b'111100',  no, dk_comp,   ao_ine):
     107  dop(do_mul,    yes, 1b'001100', yes, dk_simp2,  ao_imu):
     108  dop(do_div,    yes, 1b'001100',  no, dk_simp2,  ao_idi):
     109  dop(do_and,    yes, 1b'111100',  no, dk_bool,   ao_ban):
     110  dop(do_or,     yes, 1b'111100',  no, dk_bool,   ao_bor):
     111  dop(do_exor,   yes, 1b'001100', yes, dk_bool,   ao_bxo):
     112  dop(do_fb,     yes, 1b'011100', yes, dk_simp1,  ao_bfb):
     113  dop(do_nb,     yes, 1b'011100', yes, dk_simp1,  ao_bnb):
     114  dop(do_not,    yes, 1b'111100', yes, dk_not,    ao_bno):
     115  dop(do_fcall,   no, 1b'111100',  no, dk_fcall,  0):
     116  dop(do_scall,   no, 1b'111110',  no, dk_simp0,  0):
     117  dop(do_asin,    no, 1b'011110',  no, dk_asin,   0):
     118  dop(do_fasin,   no, 1b'001010',  no, dk_fasin,  0):
     119  dop(do_return,  no, 1b'111110',  no, dk_return, 0):
     120  dop(do_fext,   yes, 1b'101100',  no, dk_fext,   0):
     121  dop(do_if,     no,  1b'111110',  no, dk_if,     0):
     122  dop(do_goto,    no, 1b'111110',  no, dk_goto,   0):
     123  dop(do_xload,  yes, 1b'011100',  no, dk_xload,  0):
     124  dop(do_xasin,   no, 1b'001110',  no, dk_xasin,  0):
     125  dop(do_xfasin,  no, 1b'001011',  no, dk_fasin,  0):
     126  dop(do_ifnot,  no,  1b'111110',  no, dk_if,     0):
     127  dop(do_eext,    no, 1b'000100',  no, dk_eext,   0):
dsh   12  dop(do_easin,   no, 1b'000010',  no, dk_easin,  0):
dse   15  dop(do_xeasin,  no, 1b'001010',  no, dk_xeasin, 0):
     130  dop(do_xsasin,  no, 1b'001010',  no, dk_xsasin, 0):
     131  dop(do_radd,   yes, 1b'001100', yes, dk_simp2,  ao_rad):
     132  dop(do_rsub,   yes, 1b'001100',  no, dk_simp2,  ao_rsu):
     133  dop(do_rlt,    yes, 1b'001100',  no, dk_simp2,  ao_rlt):
     134  dop(do_rge,    yes, 1b'001100',  no, dk_simp2,  ao_rge):
     135  dop(do_req,    yes, 1b'001100', yes, dk_simp2,  ao_req):
     136  dop(do_rne,    yes, 1b'001100', yes, dk_simp2,  ao_rne):
     137  dop(do_rmul,   yes, 1b'001100', yes, dk_simp2,  ao_rmu):
     138  dop(do_rdiv,   yes, 1b'001100',  no, dk_simp2,  ao_rdi):
     139  dop(do_rusub,  yes, 1b'011100', yes, dk_simp1,  ao_rco):
     140  dop(do_abs,    yes, 1b'011100', yes, dk_simp1,  ao_rab):
dsj   53  dop(do_ifix,   yes, 1b'011100', yes, dk_simp1,  ao_ifr):
dsj   54  dop(do_float,  yes, 1b'011100', yes, dk_simp1,  ao_rfi):
dsj   55  dop(do_aint,   yes, 1b'011100', yes, dk_simp1,  ao_rtr):
dsj   56  dop(do_amod,   yes, 1b'001100',  no, dk_simp2,  ao_rmo):
     141  dop(do_iabs,   yes, 1b'011100', yes, dk_simp1,  ao_iab):
     142  dop(do_mod,    yes, 1b'001100',  no, dk_mod  ,  ao_imo):
     143  dop(do_sign,   yes, 1b'001100',  no, dk_simp2,  ao_rsi):
     144  dop(do_isign,  yes, 1b'001100',  no, dk_simp2,  ao_isi):
     145  dop(do_dim,    yes, 1b'001100',  no, dk_dim  ,  ao_rsu):
     146  dop(do_idim,   yes, 1b'001100',  no, dk_dim  ,  ao_isu):
     147  dop(do_seq,     no, 1b'001100',  no, dk_seq,    0):
     148  dop(do_sne,     no, 1b'001100',  no, dk_seq,    0):
     149  dop(do_goby,    no, 1b'011111',  no, dk_goby,   0);
     150
     151      $   the deferring entry is one if entry can be deferred and
     152      $   zero if it cannot be deferred.  if no input, the entry
     153      $   is one indicating it can be deferred, but later code
     154      $   detects that actually no input.
     155      macdrop(dop)
     156
     157
     158      size  work(ps), work1(ps);     $ temporary operands.
     159      size  i(ps), j(ps);            $ temporary variables
     160      size  lab(ps);                 $ temporary label.
     161      size  type(ps);                $ type of operation.
     162      size  aop(ps);                 $ operation to issue.
     163      size  resform(ps);             $ result form.
     164      size  invform(ps);             $ inverse forms.
     165      size  mask(ws);                $ mask used for -not-.
     166
     167 .+trace.  $ assembler trace code
     168      if  trace_o then $ trace is wanted.
     169          tintl('dop', dopcode)
     170          if  dopcode>0 & dopcode<=num_do  then
     171              textl(' ') textl(dopname(dopcode))  textl(' ')
     172              end if;
     173
     174          tintl('i', dopir)
     175          tintl('j', dopjr) tintl('k', dopkr)
     176          tintl('l', doplr) tintl('o', dopor)  endl
     177          end if;
     178 ..trace
     179
     180 .+defer.  $ code used only if defering ops.
     181      if  (opt_d = no) go to issue;  $ skip if not defering.
     182
     183      $   check if any inputs to this operation are unevaluated
     184      $   operations and the corresponding input is not allowed
     185      $   to be such operations.  if so, branch to -reissue- to process
     186      $   and evaluate that operation.
     187
     188      if  dt_d1 doptab(dopcode) = no then  $ check first operand.
     189          dophold = dout(dopir);  $ get result op.
     190          if  (dophold) go to reissue;  $ branch if there is one.
     191          end if;
     192
     193      if  dt_d2 doptab(dopcode) = no then  $ second operand
     194          dophold = dout(dopjr);
     195          if  (dophold) go to reissue;
     196          end if;
     197
     198      if  dt_d3 doptab(dopcode) = no then  $ third operand
     199          dophold = dout(dopkr);
     200          if  (dophold) go to reissue;
     201          end if;
     202
     203      if  dt_d4 doptab(dopcode) = no  then  $ fourth operand.
     204          dophold = dout(doplr);
     205          if  (dophold)  go to reissue;
     206          end if;
     207
     208      if  dt_do doptab(dopcode) = no then  $ output
     209          dophold = dout(dopor);
     210          if  (dophold) call aermey(31);
     211          end if;
     212
     213      if  dopnx then  $ check arguments.
     214          if  dt_dx doptab(dopcode) = no then  $ must not be deferred.
     215              do  i = 1 to dopnx;  $ test each one.
     216                  dophold = dout(dopxr(i));
     217                  if  (dophold) go to reissue;
     218                  end do;
     219              end if;
     220          end if;
     221
     222
     223      $   check if this operation itself is to be deferred.
     224      if  dt_defer doptab(dopcode) then  $ it is to be deferred.
     225          if  (dopfree = 0) go to issue;   $ table is full.
     226
     227          $   after having verified that a table entry exists, build
     228          $   one for this operation.
     229          doptr = dopfree;  dopfree = dp_chain dops(dopfree);
     230          dops(doptr) = 0;  $ clear entry.
     231          dp_inp1 dops(doptr) = dopir;  $ set first input.
     232          dp_inp2 dops(doptr) = dopjr;  $ set second input.
     233          dp_inp3 dops(doptr) = dopkr;  $ set third input.
     234          dp_oup  dops(doptr) = dopor;  $ set output.
     235          dp_op   dops(doptr) = dopcode;  $ set operation code.
     236          dp_nargs dops(doptr) = dopnargs;  $ set number of inputs.
     237 .+trace  if  trace_o then  tintl(' *defer*', doptr) endl end if;
     238          dout(dopor) = doptr; $ point back to this operation.
     239          di_count ditem(dr_item dreg(dopor)) =  $ decrement count.
     240              di_count ditem(dr_item dreg(dopor)) - 1;
     241
     242          return;  $ done with this case
     243          end if;
     244
     245 /issue/  $ issue operation
     246 ..defer
     247
     248      $   extract fields from descriptive table to determine type
     249      $   of processing needed for each operation.
     250      type = dt_type doptab(dopcode);  $ -goto- index.
     251      aop = dt_aop doptab(dopcode);  $ operation code for lower-level.
     252
     253      $   branch on operation type.
     254      go to l(type) in 1 to num_dk;
     255
     256 /l(dk_comp)/
     257      $   comparison operators.  merely check for deferred inputs.
     258 .+defer.
     259      dophold = dout(dopir);  $ get first input operation.
     260      if  (dophold) go to reissue;  $ this is not ok.
     261      dophold = dout(dopjr);  $ check second operand.
     262      if  (dophold) go to reissue;
     263 ..defer
     264     go to l(dk_simp2);
     265
     266
     267 /l(dk_simp2)/
     268      $   simple two-operand operations.  in this case call
     269      $   a routine to check for special cases and just issue
     270      $   the operation.
     271
     272      $   check for multi-word.
     273      if  (ismw(dopir) ! ismw(dopjr)) go to multi;
     274
     275      $   see if special case.
     276      call special;
     277      if  (isspecial) go to endop;  $ done if so.
     278
     279      $   set status flags.
     280      lastuse(dopir); lastuse(dopjr); lastuse(dopor);  $ set status.
     281      bin_op(aop, dopor, dopir, dopjr);  $ issue operation.
     282      go to endop;  $ done.
     283
     284 /l(dk_simp1)/
     285      $   simple unary operation.
     286      if  (ismw(dopir)) go to multi;  $ check for multi-word.
     287      lastuse(dopir); lastuse(dopor);  $ set status.
     288      un_op(aop, dopor, dopir);  $ issue operation.
     289      go to endop;
     290
     291 /l(dk_simp0)/
     292      $   operations without arguments.
     293      call_op;  $ this can only be a call.
     294      go to endop;
     295
     296 /l(dk_bool)/
     297      $   boolean operation (.or., .and., .exor.).
     298      $   in this case call a routine to check for special cases.
     299      $   otherwise, process as simple operation.
     300
     301 .+defer.
     302      $   since these operands can be deferred must check that they
     303      $   are not in this case. this arises in the case of an assignment
     304      $   to a variable of a logical expression.  i.e., in the
     305      $   statement        x = (i>j ! a = b);
     306      $   in this case, the two comparisons and the -or- will be
     307      $   deferred in the hope that this is part of an -if- statement.
     308      $   when it is discovered that it is not, the comparisons must
     309      $   be performed prior to performing the -or- operation.
     310      dophold = dout(dopir); $ check first input.
     311      if  (dophold) go to reissue;  $ force evaluation.
     312      dophold = dout(dopjr);  $ check second input.
     313      if  (dophold) go to reissue;  $ force evaluation.
     314 ..defer
     315
     316      go to l(dk_simp2);  $ else, process as simple operation.
     317
     318 .+eab.
     319 /l(dk_fnb)/
     320      $   .fb. or .nb. operation.
     321      $   in this case, a check is made to see if the operand is
     322      $   not in standard form.  in this (unlikely) case, the operation
     323      $   is a no-op and will merely cause a copy, if needed.
     324
     325      if  (ismw(dopir)) go to multi;  $ check for multi-word.
     326
     327          $   this is the normal case.  put into register 0 and call
     328          $   offline routine.  upon return from this routine, the
     329          $   result will be in register 0.
     330          lastuse(dopir);  $ indicate last use in processor.
     331          forcezero(dopir, no);  $ force value into r0.
     332          if  dopcode = do_nb then  $ set routine name.
     333              dopsname = 'nbop$sw';  $ single-word .nb.
     334          else    $ must be .fb.
     335              dopsname = 'fbop$sw';  $ single-word .fb.
     336              end if;
     337          callnodrop = yes;   call_op;  $ issue call
     338          lastuse(dopor); $ set status.
     339          inzero(dopor, no);  $ show value in r0.
     340      go to endop;  $ done.
     341 ..eab
     342
     343 /l(dk_not)/
     344      $   .not. operation.
     345
     346 .+defer.
     347      $   check if input is a deferred operation.  this can occur for
     348      $   similar reasons as for booleans.
     349      dophold = dout(dopir);  $ see if deferred result.
     350      if  (dophold) go to reissue;
     351 ..defer
     352
     353      if  (ismw(dopir)) go to multi;  $ handle multi-word.
     354
     355      $   see if this is a full word .not.
     356      if  syze(dopir) = mws then  $ it is full word.
     357          lastuse(dopir);  lastuse(dopor);  $ set status.
     358          not_op(dopor, dopir);  $ negate.
     359      else    $need longer code.
     360          getdreg(work);   $ get a temporary.
     361          lastuse(dopir);  $ set status.
     362          not_op(work, dopir);  $ negate input.
     363          lastuse(work);  lastuse(dopor);  $ set status.
vaxa 173 .+t10    lpr_op(dopor, work, 0, syze(dopor));  $ extract significant pa
vaxa 174 .+t32    assignconst(i, 0);  lastuse(i);  $ get first bit.
vaxa 175 .+t32    assignconst(j, syze(dopor)); lastuse(j);  $ get length.
vaxa 176 .+t32    lpr_op(dopor, work, i, j);  $ extract significant pa
     365          end if;
     366
     367      go to endop;  $ done.
     368
     369 /l(dk_fcall)/
     370      $   function call.  issue call and retrieve result from r0.
dsk  290      forcezero(0, no); call_op;
     372      lastuse(dopor); inzero(dopor, ismw(dopor)); $ get result.
     373      go to endop;  $ done.
     374
     375 /l(dk_asin)/
     376      $   simple assignment.
     377      $   first, check for multi-word case.  in multi-word case, move
     378      $   and clear, as appropriate.
     379      if  ismw(dopir) then  $ multi-word output.
     380
     381 .+defer.
     382          $   first, check if input is a deferred operation and force
     383          $   evaluation if so.
     384          dophold = dout(dopjr); $ check input.
     385          if  (dophold) go to reissue;
     386 ..defer
     387
     388          if  ismw(dopjr) then  $ multi-word input too.
     389              if  nwords(dopjr) < nwords(dopir) then  $ must clear
     390                  getaddr(work, dopir, 1, 0);  $ get address.
     391                  i = nwords(dopir)-nwords(dopjr);  $ get no. of words.
     392                  clear_op(work, i);  $ clear first part.
     393              else  $ will fit.  need not clear.
     394                  i = 0;  $ set start offset to zero.
     395                  end if;
     396              getaddr(work, dopir, i+1, 0);  $ get proper word.
     397              getaddr(work1, dopjr, 1 + idim(nwords(dopjr),  $ source.
     398                  nwords(dopir)), 0);  $ place to start move from.
     399              lastuse(work1); lastuse(work);  $ set status.
     400                  smove_op(work, work1, nwords(work)-i);  $ move source.
     401          else  $ source is single-word.
     402              i = nwords(dopir);  $ save for later.
     403              getaddr(work, dopir, 1, 0);  $ first word.
     404
     405              $   check for special case of assignment to zero.
     406              if  isscon(dopjr) & conval(dopjr) = 0 then
     407                  lastuse(work);  $ set status.
     408                  clear_op(work, i);  $ clear.
     409                  lastuse(dopjr); drop(dopjr);
     410              else  $ store in word.
     411                  clear_op(work, i-1);  $ clear all but last word.
     412                  lastuse(dopir);  lastuse(dopjr);  $ set status.
     413                  storeword(dopjr, dopir, i, 0);  $ store into last word
     414                  $   clear all but last word.
     415                  end if;
     416              end if;
     417      else   $ simple, single-word assignment.
     418
     419 .+defer.
     420          $   check for the case where the operation of the input
     421          $   is of a very simple type.  in this case, the operation
     422          $   can be issued with the assignment target as its output
     423          $   provided that this is last use of input.  this will
     424          $   generate more efficient code in many cases.
     425          dophold = dout(dopjr);  $ get input op.
     426          if  dophold then  $ check if this is special.
     427              if  (di_ldrop ditem(dr_item dreg(dopjr)) = no !
     428                  di_count ditem(dr_item dreg(dopjr)) ^= 1)
     429                  go to reissue;   $ cannot modify output yet.
     430              if  (dt_spcasin doptab(dp_op dops(dophold)) = no)
     431                  go to reissue;  $ not special operation.
     432
     433              $   get inputs of this operation and check for
     434              $   multi-word.
     435              work = dp_inp1 dops(dophold);   $ set new first input.
     436              work1 = dp_inp2 dops(dophold);   $ set new second input.
     437              i = dp_nargs dops(dophold);  $ save argument count.
     438              if  (ismw(work)) go to reissue;
     439
dsk  291              if  dout(work)  then  $ input is a deferred op.
dsk  292                  dophold = dout(work);  go to reissue;  $ reissue it.
dsk  293                  end if;
dsk  294
     440              $   check for 1 or 2 operand operation and process.
     441              if  i=2  then  $ 2-operand.
     442                  if  (ismw(work1)) go to reissue;  $ not special.
dsk  295                  if  dout(work1)  then  $ input is a deferred operation
dsk  296                      dophold = dout(work1);  go to reissue;
dsk  297                      end if;
dsk  298
     443                  using(work1);   $ show using this operand.
     444                  end if;
     445
     446              $   kill the input operation and reset to issue
     447              $   this operation again differently.
     448              using(work);   $ show using this input.
     449              kill(dopjr);  $ drop old operation.
     450              dopor = dopir;  dopir = work;
     451              dopjr = work1;  dopnargs = i;
     452              dopcode = dp_op dops(dophold);  dophasout = yes;
     453
     454              $   if the output is the same as an input, can reset
     455              $   live status.
     456              if  dopor = dopir ! (dopor = dopjr & dopnargs = 2 ) then
     457                  if  dr_reg dreg(dw_freg dword(dr_word dreg(dopir)))
rkd   11                      ^=0 & (dopor=dopir) then
rkd   12                             rl_subtype reglis(dr_reg dreg(dopir))
     459                          = rt_need;
     460                      end if;
rkd   13                  if  dopnargs=2  then
rkd   14                      if dr_reg dreg(dw_freg dword(dr_word dreg(dopjr)))
rkd   15                          ^=0 & (dopor=dopjr)  then
rkd   16                             rl_subtype reglis(dr_reg dreg(dopjr))
rkd   17                              = rt_need;
rkd   18                          end if;
rkd   19                      end if;
     461                  spcdrop = yes;  $ set special -clear- operation.
     462
     463                  $   since the usage count of the input should
     464                  $   be one less then it is, must decrement usage
     465                  $   count.  however, must also pre-decrement the
     466                  $   lastuse count so that this ihem is not dropped
     467                  $   too early.
     468                  di_count ditem(dr_item dreg(dopor)) =
     469                      di_count ditem(dr_item dreg(dopor)) - 1;
     470                  di_luse ditem(dr_item dreg(dopor)) =
     471                      di_luse ditem(dr_item dreg(dopor))
     472                          + di_luseminus1val;
     473                  end if;
     474
     475              clear(dopor);  $ clear output.
     476              spcdrop = no;  $ clear in case special was set.
     477              go to issue;  $ re-issue.
     478              end if;
     479 ..defer
     480
     481          clear(dopir);  $ clear output
     482          getword(dopjr, dopjr, nwords(dopjr), 0);  $ get proper word.
     483          lastuse(dopir); lastuse(dopjr);  $ set status
     484          move_op(dopir, dopjr);  $ move (copy if needed)
     485          end if;
     486
     487      go to endop;  $ done.
     488
     489 /l(dk_fasin)/
     490      $   .f. assignment.
     491      $   set register containing first bit and ensure that opcode
     492      $   is for a field and not a character assignment.
     493      work = dopkr;  $ this is case for non-indexed.
     494      if  (dopcode = do_xfasin)  work = dopxr(1);
     495
     496      call asmfld(work, doplr, dopir, dopjr);  $ do .f. assignment.
     497 .+defer  if  (dophold) go to reissue;
     498
     499      go to endop;  $ done.
     500
     501 /l(dk_return)/
     502      call aermey(4);   $ this should not occur.
     503
     504 /l(dk_fext)/
     505      $   .f. field extraction.
     506      call asmfld(dopir, dopjr, dopkr, 0);  $ do .f. extract
     507 .+defer  if  (dophold) go to reissue;
     508
     509      go to endop;  $ done.
     510
     511 /l(dk_xload)/
     512      $   indexed load operation.  calculate storage offset and
     513      $   either shift or multiply index over.  then get desired
     514      $   address or value.
     515 .+defer.
     516      call asmdxchk(dopjr);   $ check index.
     517      if  (dophold) go to reissue;
     518 ..defer
     519
     520      doff = nwords(dopir);  call asmxload(dopir, dopjr);
     521
     522      $   in multi-word case, get address of first (left-most) word.
     523      $   in single-word case, get the word.
     524      if  ismw(dopir) then  $ multi-word.
     525          if  dopjr then  lastuse(dopir);   lastuse(dopjr); end if;
     526          getaddr(work, dopir, doff, dopjr);  $ get addr.
     527          lastuse(work); lastuse(dopor);  $ set status.
     528          call moveaddr(dopor, work);  $ move address to -dopor-.
     529      else    $ single-word case.
     530          if  dopjr then lastuse(dopir);  lastuse(dopjr); end if;
     531          getword(work, dopir, doff, dopjr);  $ get word.
     532          $   move to output value.
     533          lastuse(dopor); lastuse(work); $ set status.
     534          move_op(dopor, work);  $ issue move.
     535          end if;
     536      go to endop;  $ done.
     537
     538 /l(dk_xasin)/
     539      $   indexed assignment.
     540      call asmxasin;  $ call routine to generate indexed assignment.
     541 .+defer  if  (dophold) go to reissue;  $ must reissue prior op.
     542      go to endop;  $ done.
     543
     544 /l(dk_eext)/
     545      $   .e. extraction.  handle as routine call.
     546      dopxr(1) = dopir;  $ first parameter is first bit.
     547      dopxr(2) = dopjr;  $ second parameter is length.
     548      dopxr(3) = dopkr;  $ third is source.
     549      assignconst(dopxr(4), syze(dopkr)) $ length of source.
     550      dopxr(5) = dopor;  $ target.
     551      assignconst(dopxr(6), syze(dopor)) $ length of target.
     552      dopsname = longname(vo_eext);  $ get routine name.
     553      callnodrop = yes; dopnx = 6; call_op;  $ call with six parameters.
     554      go to endop;  $ done.
     555
     556 /l(dk_easin)/
     557      $   .e. assignment.  call off-line routine.
     558      dopxr(1) = dopkr;  $ first parameter is first bit.
     559      dopxr(2) = doplr;  $ second is length.
     560      dopxr(3) = dopjr;  $ third is source.
     561      assignconst(dopxr(4), syze(dopjr)) $ length of source.
     562      dopxr(5) = dopir;  $ target.
     563      assignconst(dopxr(6), syze(dopir)) $ length of target.
     564      dopsname = longname(vo_easin);  $ get routine name.
     565      callnodrop = yes; dopnx = 6; call_op;  $ call with six parameters.
     566      go to endop;  $ done.
     567
     568 /l(dk_xeasin)/
     569      $   .e. indexed assignment.  calculate address of target and
     570      $   call off-line routine.
     571 .+defer.
     572      call asmdxchk(dopkr);  $ check index.
     573      if  (dophold) go to reissue;
     574 ..defer
     575      doff = nwords(dopir);  call asmxload(dopir, dopkr);
     576
     577      $   set up parameters for call.
     578      $   (first parameter already set - first bit position)
     579      dopxr(2) = doplr;  $ second parameter is length.
     580      dopxr(3) = dopjr;  $ third parameter is source.
     581      assignconst(dopxr(4), syze(dopjr)) $ length of source.
     582      assignconst(dopxr(6), syze(dopir))  $ length of target.
     583      if  dopkr then lastuse(dopkr); lastuse(dopir);  end if;
     584      getaddr(work, dopir, doff, dopkr); dopxr(5) = work;
     585      dopsname = longname(vo_easin);  $ get routine name.
     586      callnodrop = yes; dopnx = 6; call_op;  $ call with six parameters.
     587      go to endop;  $ done.
     588
     589 /l(dk_xsasin)/
     590      $   indexed .s. assignment.  get address of target and call
     591      $   off-line routine.
     592 .+defer.
     593      call asmdxchk(dopkr);  $ check index.
     594      if  (dophold) go to reissue;
     595 ..defer
     596      doff = nwords(dopir);  call asmxload(dopir, dopkr);
     597
     598      $   set up parameters.  (parameter one is already set up)
     599      dopxr(2) = doplr;  $ length.
     600      dopxr(3) = dopjr;  $ source.
     601      if  dopkr then  lastuse(dopir); lastuse(dopkr); end if;
     602      getaddr(work, dopir, doff, dopkr); dopxr(4) = work;
     603      dopsname = longname(vo_sasin);  $ get name.
     604      callnodrop = yes; dopnx = 4; call_op;  $ call with four parms.
     605      go to endop;  $ done.
     606
     607 /l(dk_goto)/
     608      $   go to operation.   just issue.
     609      goto_op(dopir);  $ branch to label.
     610      go to endop;   $ done.
     611
     612 /l(dk_if)/
     613      $   -if- operation.  in complicated case, call a routine to
     614      $   generate code.  otherwise, just issue the appropriate branch.
     615
     616 .+defer.
     617      dophold = dout(dopir);   $ get deferred op for input, if any.
     618 .+ifopt.
     619      if  dophold then  $ must do something.
     620          if  (opt_f) call asmif;  $ if optimization, call routine.
     621          if  (dophold) go to reissue;  $ if must reissue something.
     622          go to endop;   $ otherwise done with operation.
     623          end if;
     624 .-ifopt  if  (dophold) go to reissue;  $ if no optimzation, evaluate.
     625 ..defer
     626
     627      $   simple case - select branch instruction from form of input.
     628
     629      aop = bm_zer;
     630      if  (dopcode = do_if) aop = binv(bm_zer);  $ invert aop.
     631      lastuse(dopir);   $ set status.
     632      if_op(aop, dopir, dopjr);  $ issue branch.
     633      go to endop;  $ done.
     634
     635 /l(dk_seq)/
     636      $   .seq. or .sne. comparison.  handle as function call.
     637      dopxr(1) = dopir;  $ first parameter is input 1.
     638      dopxr(2) = dopjr;  $ second parameter is input 2.
     639      dopsname = longname(vo_seq);  $ get routine name.
rkc    9      forcezero(0, no);  $ free up r0.
     640      callnodrop = yes;  dopnx = 2; call_op;  $ call routine.
dsk  299      inzero(dopor, no);  $ show function result.
dsk  300      if  dopcode = do_sne  then  $ see if this was .sne.
dsk  301          lastuse(dopor);  $ set lastuse status.
dsk  302          assignconst(work, 1);  $ set to a one.
dsk  303          exor_op(dopor, dopor, work);  $ negate value.
dsk  304      else  $ this was a .seq.
dsl   13          kill(dopor);  $ simply drop output.
dsk  306          end if;
dsk  307
     643      go to endop;   $ done.
     644
     645 /l(dk_mod)/
     646      $   -mod- function.  check for a power of two.
     647      if  .nb. conval(dopjr) = 1 then  $ it is.
     648          assignconst(work, conval(dopjr)-1);  $ get mask.
     649          kill(dopjr);  $ drop unused constant.
     650          lastuse(dopor); lastuse(dopir); lastuse(work);
     651          and_op(dopor, dopir, work);  $ do as -and- with mask.
     652          go to endop;  $ done in this special case.
     653          end if;
     654
     655      $   otherwise process as normal operation.
     656      go to l(dk_simp2);
     657
     658 /l(dk_dim)/
     659      $   -idim- or -dim- function.  generate as subtraction and test.
     660      lastuse(dopir); lastuse(dopjr);   $ set status.
     661      bin_op(aop, dopor, dopir, dopjr);  $ do subtraction.
     662
     663      $   get label and generate test.
     664      labget(lab);  $ get a label.
     665      ifpos_op(dopor, lab);  $ done if positive.
     666      sub_op(dopor, dopor, dopor);  $ else set to zero.
     667      labdef(lab, no);  $ define label.
     668      labfree(lab);  $ and free it.
     669      kill(dopor);  $ free output.  note that this could not have
     670                    $ been done on the subtract because of the label.
     671      go to endop;
     672
     673 /l(dk_goby)/     $ indexed -goto- operation.
     674      call asmgoby;   $ call routine to process.
     675      go to endop;  $ done with this operation.
     676
     677 /multi/
     678      $   multi-word operation found.  call routine to generate
     679      $   call (or maybe inline code for some).
     680      call asmlong;
     681      go to endop;  $ done with this operation.
     682
     683
     684 /endop/
     685
     686      $   must do the housekeeping for the end of an operation.
     687
     688      do  i = r0 to rhi;  $ first clear all hold bits.
     689          rl_hold reglis(i) = no;  $ clear normal hold.
     690          rl_addrhold reglis(i) = no;  $ clear address hold.
dse   16          if  (rl_type reglis(i) = rt_dead)  reglis(i) = 0;
     691          end do;
     692
     693
     694 .+trace.   $ write out desired traces.
     695      if  (trace_d) call dumpdregs;
     696      if  (trace_r) call dumpmregs;
     697 ..trace
     698
     699
     700      return;  $ done with operation.
     701
     702
     703 .+defer.
     704 /reissue/  $ reissue current operation and process operation pointed
     705      $   to by -dophold-.
     706
     707      $   must check to see if this is an intermediate
     708      $   operation being passed over.  in that case, this
     709      $   operation must be deferred again.
     710      if  reissuedop then  $ this is intermediate operation.
     711          if  (dopfree = 0) call aermey(29);   $ table is full.
     712
     713          $   after having verified that a table entry exists, build
     714          $   one for this operation.
     715          doptr = dopfree;  dopfree = dp_chain dops(dopfree);
     716          dops(doptr) = 0;  $ clear entry.
     717          dp_inp1 dops(doptr) = dopir;  $ set first input.
     718          dp_inp2 dops(doptr) = dopjr;  $ set second input.
     719          dp_inp3 dops(doptr) = dopkr;  $ set third input.
     720          dp_oup  dops(doptr) = dopor;  $ set output.
     721          dp_op   dops(doptr) = dopcode;  $ set operation code.
     722          dp_nargs dops(doptr) = dopnargs;  $ set number of inputs.
     723 .+trace  if  trace_o then  tintl(' *defer*', doptr) endl end if;
     724          dout(dopor) = doptr; $ point back to this operation.
     725          di_count ditem(dr_item dreg(dopor)) = $ decrement usage count.
     726              di_count ditem(dr_item dreg(dopor)) - 1;
     727      else    $ this is not intermediate operation.
     728          $   must drop all inputs of current operation to make it
     729          $   look as though the operation was never issued.
     730          spcdrop = yes;  $ set for special handling in -dropr-.
     731          go to n1(dopnargs) in 0 to 4;  $ drop arguments.
     732
     733 /n1(4)/  kill(doplr);
     734 /n1(3)/  kill(dopkr);
     735 /n1(2)/  kill(dopjr);
     736 /n1(1)/  kill(dopir);
     737 /n1(0)/
     738
     739          if  dophasout  then   kill(dopor);  end if;
     740
     741          if  dopnx ^= 0 & dopcode ^= do_goby then  $ free extra args.
     742              do  i = 1 to dopnx;
     743                  kill(dopxr(i));
     744                  end do;
     745              end if;
     746
     747          spcdrop = no;  $ reset flag.
     748
     749          reissuedop = yes;  $ flag for -asmprog- to re-issue.
     750          end if;
     751
     752      $   clear output pointer of output of this operation.
     753      dout(dp_oup dops(dophold)) = 0;  $ because will do now.
     754
     755      $   reset variables to point to operation.
     756 .+trace  if  trace_o then  tintl(' *reset*', dophold) endl end if;
     757      dopcode = dp_op dops(dophold);  $ get operation code.
     758      dopor = dp_oup dops(dophold);   $ ... output.
     759      dopir = dp_inp1 dops(dophold);  $ ... input 1.
     760      dopjr = dp_inp2 dops(dophold);  $ ... input 2.
     761      dopkr = dp_inp3 dops(dophold);  $ ... input 3.
     762      dopnargs = dp_nargs dops(dophold);  $ ... number of inputs.
     763      $   count use of the output again.
     764      using(dopor);   $ because dropped when deferred.
     765
     766
     767      $   insert on free queue.
     768      dp_chain dops(dophold) = dopfree; dopfree = dophold;
     769
     770      go to issue;   $ issue operation.
     771 ..defer
     772
     773      macdrop(dt_dx)      macdrop(dt_do)
     774      macdrop(dt_d4)
     775      macdrop(dt_d3)      macdrop(dt_d2)
     776      macdrop(dt_d1)      macdrop(dt_defer)
     777      macdrop(dt_spcasin) macdrop(dt_type)
     778      macdrop(dt_aop)     macdrop(dt_resform)
     779
     780      macdrop(dk_asin)    macdrop(dk_bool)
     781      macdrop(dk_casin)   macdrop(dk_cext)
     782      macdrop(dk_easin)   macdrop(dk_eext)
     783      macdrop(dk_fasin)   macdrop(dk_fcall)
     784      macdrop(dk_fext)    macdrop(dk_fnb)
     785      macdrop(dk_goto)    macdrop(dk_if)
     786      macdrop(dk_not)     macdrop(dk_simp0)
     787      macdrop(dk_simp1)   macdrop(dk_simp2)
     788      macdrop(dk_xasin)   macdrop(dk_xeasin)
     789      macdrop(dk_xfasin)  macdrop(dk_xload)
     790      macdrop(dk_xsasin)  macdrop(dk_mod)
     791      macdrop(dk_dim)     macdrop(dk_goby)
     792      macdrop(num_dk)
     793
     794      end subr emitdop;
       1 .=member asmxasi
       2      subr asmxasin;   $ process indexed assignment.
       3      size  work(ps), work1(ps);    $ work registers.
       4      size  i(ps), j(ps);           $ temporaries.
       5
       6 .+defer.
       7      call asmdxchk(dopkr);   $ check index.
       8      if  (dophold) return;
       9 ..defer
      10
      11      doff = 1;  call asmxload(dopir, dopkr);   $ process index.
      12
      13      $   check for multi-word cases.
      14      if  ismw(dopir) then  $ target multi-word.
      15          j = nwords(dopir);  $ get no. of words for later.
      16          if  ismw(dopjr) then  $ source multi-word.
      17              $   have two cases depending on the sizes of source
      18              $   and target.
      19              if  nwords(dopjr) < nwords(dopir) then  $ must zero-fill.
      20                  getaddr(work, dopir, doff, dopkr);  $ get address.
      21                  i = nwords(dopir)-nwords(dopjr);  $ length to clear.
      22                  if  dopkr then   lastuse(work);  end if;
      23                  clear_op(work, i);  $ clear to zero.
      24              else  $ need not zero-fill.
      25                  i = 0;  $ difference is zero.
      26                  end if;
      27              if  dopkr then lastuse(dopir); lastuse(dopkr);   end if;
      28              getaddr(work, dopir, doff+i, dopkr);
dsa   14              getaddr(work1, dopjr, 1+idim(nwords(dopjr),j), 0);
      30              $   move in source.
      31              lastuse(work1); lastuse(work);  $ set status.
      32              smove_op(work, work1, (j-i));
      33              return;  $ done.
      34          else  $ source is single-word.
      35              $   check for special case of assigning zero.
      36              if  isscon(dopjr) & conval(dopjr) = 0 then
      37                  kill(dopjr);  $ free the zero.
      38                  $   point to first word in variable.
      39                  if  dopkr then lastuse(dopkr);lastuse(dopir); end if;
      40                  getaddr(work, dopir, doff, dopkr);
      41                  lastuse(work);  $ set status.
      42              clear_op(work, j);  $ clear to zero.
      43                  return;  $ done.
      44              else  $ must clear high-order.
      45                  getaddr(work, dopir, doff, dopkr);
      46              lastuse(work);  $ set status  $ check with s37 chngs
      47              clear_op(work, (nwords(dopir)-1));  $ clear to zero.
      48                  $   fall through to single-word case.
      49                  end if;
      50              end if;
      51          end if;
      52
      53      $   in single-word case, merely store source into target array.
      54      lastuse(dopir); lastuse(dopjr);  $ set status.
      55      if  dopkr then  lastuse(dopkr); end if;
      56      storeword(dopjr, dopir, doff+nwords(dopir)-1, dopkr);  $ store.
      57
      58      end subr asmxasin;
       1 .=member asmdata
       2      subr asmdata;  $ process -data- statement.
       3      $   -data- statements are processed by chaining them in order of
       4      $   increasing subcript value, to the variable that it being
       5      $   initialized.
       6      size  i(ps), j(ps);         $ pointers.
       7      size  ind(ps);              $ index value.
       8
       9      $   first get index value.  if this is not for subscripted
      10      $   variable or if the subscript is left out, set the index
      11      $   to 1.
      12      i = vv_inp3 voa(voaep);  $ -voa- pointer to index.
      13      if  i then   $ if index given.
      14          ind = val(vv_vbeg voa(i));  $ load value.
      15      else    $   not given.
      16          ind = 1;  $ set to one.
      17          end if;
      18
      19      $   index will be stored in -vv_inp1- of -data- operation for
      20      $   later use.
      21      vv_inp1 voa(voaep) = ind;
      22
      23      $   get pointers to variable to be initialized and to the
      24      $   start of the data chain for it.
      25      i = ha_ep ha(vv_naym voa(voaep));  $ point to -voa- entry.
      26 .-vvfrs  j = vv_frsdata voa(i);  $ point to head of chain
      27 .+vvfrs  j = vvfrsdata(i);  $ point to head of chain.
      28
      29      $   check if a chain is present.
      30      if  j then  $ a chain is present.
      31          $   see if this index is lower than the first entry in chain.
      32          $   if so, then this becomes the first index in the chain.
      33          if  ind < vv_inp1 voa(j) then  $ this becomes first in chain.
      34              vv_inp2 voa(voaep) = j; $ maintain chain.
      35 .-vvfrs  vv_frsdata voa(i) = voaep;
      36 .+vvfrs  vvfrsdata(i) = voaep;
      37          else    $   not below first in chain.
      38              $   search for the place at which this new entry
      39              $   should be inserted in the chain.  the 'maybe' loop
      40              $   is exited when the entry has been added to the chain.
      41              until  yes;  $ exit when added to chain/
      42                  while  vv_inp2 voa(j);  $ loop while more in chain.
      43                      i = vv_inp2 voa(j);  $ set to next in chain.
      44                      if  ind < vv_inp1 voa(i) then  $ insert here.
      45                          vv_inp2 voa(voaep) = i;
      46                          vv_inp2 voa(j) = voaep;  $ put into chain.
      47                          quit until;  $ show in chain.
      48                          end if;
      49                      j = i;  $ step to next in chain next time around.
      50                      end while;
      51
      52                  $   if reach here, the entry is higher than any in
      53                  $   the chain so add to end.
      54                  vv_inp2 voa(voaep) = 0;  $ set to end of chain.
      55                  vv_inp2 voa(j) = voaep;  $ point to new entry.
      56                  end until;
      57              end if;
      58
      59      else    $   chain is empty -- put as first entry.
      60          vv_inp2 voa(voaep) = 0;  $ show last in chain.
      61 .-vvfrs  vv_frsdata voa(i) = voaep;  $ show first also.
      62 .+vvfrs  vvfrsdata(i) = voaep;  $ show first also.
      63          end if;
      64
      65      end subr asmdata;
       1 .=member asmgoby
       2      subr asmgoby;  $ generate code for indexed goto.
       3      $   this routine generates code for the indexed goto operation.
       4      size  i(ps);            $ loop variable.
       5      size  lab(ps);          $ temporary label.
       6      size  lab1(ps);         $ second label.
       7      size  reg(ps);          $ temporary dummy register.
       8      size  mreg(ps);         $ machine register.
       9      size  mode(ps);          $ machine mode for label table.
      10      size  moff(mosize);       $ machine offset for label table.
      11      size  t(ws);           $ temporary.
vaxa 177      size  work(ps);           $ temporary dreg.
vaxa 178 .+t32    size  work2(ps);     $ temporary dreg.
      12
      13      $   define a label to indicate that the index is acceptable
      14      $   so far and branch to it if the index is strictly positive.
      15      labget(lab);  $ get a temporary label.
      16      ifspos_op(dopir, lab);  $ branch if greater than zero.
      17
      18      $   define an error point at this location.
      19      labget(lab1);  $ get a label.
      20      labdef(lab1, no);  $ define it locally.
      21
      22      $   call an error routine.  put the bad index () into
      23      $   r0 and call the routine with no parameters.
      24      forcezero(dopir, no);  $ force into r0.
      25      i = dopnx;  $ save no. arguments for later.
      26      dopnx = 0; dopsname = 'goto$er';  call_op;  $ call with no args.
      27      dopnx = i;  $ restore number of arguments.
      28
      29      $   define the 'good-so-far' label and check if the index
      30      $   is too high.
      31      labdef(lab, no);  $ define the label locally.
      32      labfree(lab);  $ this is last use of that label.
      33      assignconst(reg, dopnx);  $ get no. to compare with.
      34      lastuse(reg);    $ set status.
      35      cmp_op(bm_pos, dopir, reg, lab1);  $ do compare.
      36      labfree(lab1);  $ done with this label.
      37
vaxa 179 .+t10    work = dopir;   $ copy to variable to use later.
vaxa 180 .+t32    assignconst(work2, 2);  $ get amount to shift.
vaxa 181 .+t32    getdreg(work);  $ get dummy register.
vaxa 182 .+t32    lastuse(work2);   lastuse(dopir);  $ set status.
vaxa 183 .+t32    mul2_op(work, dopir, work2);  $ shift over.
vaxa 184
vaxa 185
vaxa 186      getvar(work, gd_reg, mode, mreg, moff);  $ get index into reg
vaxa 187
vaxa 188
vaxa 189 .+t10.
      39      if  mreg = r0 then  $ check if it is in r0.
      40          $   in this case it must be moved somewhere because r0
      41          $   cannot be used as an index register.
      42          getreg(mreg, rt_live);  $ must get a register.
vaxa 190          dr_reg dreg(work) = mreg;  $ set to new register.
      44          reglis(mreg) = reglis(r0);  $ copy status.
      45          reglis(r0) = 0;  $ free register zero.
      46          end if;
vaxa 191 ..t10
vaxa 192
vaxa 193
vaxa 194      kill(work);   $ free index.
      48      $   emit an indexed branch into the label table to be built in
      49      $   the base block.
      50      moff = 0;  mbo_blk moff = bl_base;  $ set to base block
      51      $   if base block address would go negative, increment it.
      52      if (baselastaddr=1)  baselastaddr=2;
      53      t = baselastaddr - 2;
      54      if  (t<0)  t = mneg(iabs(t));  $ if negative.
      55      mbo_off moff = t;
vaxa 195 .+t10    emop(mo_jmp, r0, am_reli, mreg, moff);  $ do the branch.
vaxa 196 .+t32    emop(mo_xjm, mreg, am_mem, sparereg, moff);  $ do branch.
      57
      58      $   now insert the labels into the base block.
      59      do  i = 1 to dopnx;  $ loop over each label.
      60          baseprobelab(t, dopxr(i));  $ insert a label.
      61          end do;
      62
      63      end subr asmgoby;
       1 .=member asmif
       2 .+ifopt.
       3      subr asmif;
       4      $   this routine processes the expression of an -if- statement.
       5      $   it is used to generate the appropriate compare instructions
       6      $   rather than subtracts, exclusive-ors, etc.
       7      $
       8      $   it receives as input the tree for the expression in the -dops-
       9      $   array.  it then copies and processes the tree.  its first
      10      $   pass is to copy the tree into an internal structure.  this
      11      $   structure indicates exactly what comparisons are to be done,
      12      $   what branch mask is to be used to the true case, and what
      13      $   variables, offsets, and masks are involved.  this first pass
      14      $   also checks that everything is validly deferred and will
      15      $   return to force evaluation if not.
      16      $
      17      $   the second pass then scans the tree to actually generate the
      18      $   comparisons and branches.
      19
      20      $   the main table used by this routine is the i-f t-able (it).
      21      $   it contains the nodes of the tree built from the expression.
      22      $   the format of each node is given below.
      23      +*  it_op    = .f.   1, 8, **   $ operation type.
      24      +*  it_tlab  = .f.   9, 8, **   $ true branch label index.
      25      +*  it_flab  = .f.  17, 8, **   $ false branch label index.
      26      +*  it_dop   = .f.  25, 8, **   $ pointer to deferred operation.
      27      +*  it_llink = .f.  33, 8, **   $ left tree link pointer.
      28      +*  it_rlink = .f.  41, 8, **   $ right tree link pointer.
      29      +*  it_blink = .f.  49, 8, **   $ back pointer.
      30      +*  it_count = .f.  57, 8, **   $ number of nodes below this.
      31      +*  it_bmask = .f.  65, 8, **   $ true branch mask.
      32      +*  it_inp1  = .f.  73, 8, **   $ input one to operation.
      33      +*  it_inp2  = .f.  81, 8, **   $ second input to operation.
      34      +*  it_len   = .f. 89, 8, **   $ byte offset or mask.
      35      +*  it_rlf   = .f. 97, 1, **   $ right/left flag.
      36      +*  it_tdef  = .f. 98, 1, **   $ 'defines new true label'
      37      +*  it_fdef  = .f. 99, 1, **   $ 'defines new false label'
      38      +*  it_negfl = .f. 100, 1, **   $ 'changes status of -negfl-'
      39
      40      +*  itsz = 128 **       $ size of table.
dsd   11      $   define it fields using 32 bit (s37) as default, correct
dsd   12      $   as needed for other machines.  this not standard practice,
dsd   13      $   but acceptable as fields referenced only in this procedure.
dsd   14
dsd   15 .+s10   +*  itsz = 144 **  +* it_llink = .f. 137, 8, **
dsd   16 .+s66   +*  itsz = 120 **  +* it_count = .f. 113, 8, **
      41
      42
      43      $   the other tables that are used are the -iv- and the -il-
      44      $   tables.  -iv- contains a list of variables which will be used
      45      $   in generating the expression.  this is done so usage counts
      46      $   can be correctly maintained.  the -il- table contains a list
      47      $   of generated labels.  if an entry is zero, it means that no
      48      $   label has been assigned for that index.  if it is nonzero,
      49      $   then it is the label number.
      50
      51      $   define maximum table dimensions.
      52      +*  itmax = 32 **
      53      +*  ivmax = 30 **
      54      +*  ilmax = 20 **
      55
      56      $   define tables and pointers.
      57      size  it(itsz), itptr(ps);
      58      dims  it(itmax);
      59
      60      size  iv(ps), ivptr(ps);
      61      dims  iv(ivmax);
      62
      63      size  il(ps), ilptr(ps);
      64      dims  il(ilmax);
      65
      66
      67      $   operation types used.
      68      +*  ip_or  = 1 **   $ logical -or-.
      69      +*  ip_and = 2 **   $ logical -and-.
      70      +*  ip_cmp = 3 **   $ do simple comparison.
      71
      72      $   flag values for tree.
      73      +*  left  = 0 **    $ at left subtree.
      74      +*  right = 1 **    $ at right subtree.
      75
      76
      77      $   table for conversion of op --> branch mask.
      78      size  bmasks(ps);  dims bmasks(do_ne - (do_lt-1));
      79
      80      +*  bmi(op, bm) = bmasks(op - (do_lt-1)) = bm **
      81
      82      data    $ initialize table.
      83
      84      $   table bmi bewow is machine-independent.
      85          bmi(do_lt, bm_neg):
      86          bmi(do_ge, binv(bm_neg)):
      87          bmi(do_eq, bm_zer):
      88          bmi(do_ne, binv(bm_zer));
      89
      90      macdrop(bmi)
      91
      92
      93      size  in1(ps), in2(ps), in3(ps);   $ inputs to operation.
      94      size  optr(ps);             $ pointer to -dop-.
      95      size  negfl(1);             $ negate flag.
      96      size  opc(ps);              $ operation code.
      97      size  lptr(ps);             $ last tree entry pointer.
      98      size  one(ps);              $ register containing one.
      99      size  zero(ps);             $ register containing zero.
     100      size  nextop(ps);           $ pointer to next operation.
     101      size  bmask(ps);            $ branch mask for node.
     102      size  t(ps);                $ temporary.
     103      size  itval(itsz);          $ temporary copy of node.
     104      size  i(ps);                $ loop index.
     105      size  lab(ps);              $ temporary label and index.
     106
     107
     108      $   first, initialize variables for pass one.
     109      itptr = 0; ivptr = 0;   $ show empty tables.
     110      ilptr = 2; il(1) = dopjr; il(2) = 0;   $ initialize -il- table.
     111      optr = dophold;   $ set initial -dop- index.
     112      negfl = no;  $ set initial negation flag.
     113      lptr = 0;   $ set initial tree status.
     114
     115      assignconst(one, 1);  assignconst(zero, 0);
     116
     117
     118      $   start pass one.
     119      while  yes;   $ exit from this ends pass one.
     120          $   first, extract op-code and operands.
     121          opc = dp_op dops(dophold);  $ get operation.
     122          in1 = dp_inp1 dops(dophold);  in2 = dp_inp2 dops(dophold);
     123
     124          $   process the operation depending on type.
     125          if  opc = do_or then  $ logical or case.
     126              $   in this case, simply add an -or- operation
     127              $   to the tree (or an -and- operation if the negate
     128              $   flag is set) and set the next operation to the first
     129              $   input.
     130              $   first make sure that if any input is not deferred,
     131              $   that it is an operand of size 1.
     132              if  dout(in1) = 0 then   $ first input not deferred.
     133                  if  (syze(in1) ^= 1) go to force;
     134                  end if;
     135
     136              if  dout(in2) = 0 then   $ second input not deferred.
     137                  if  (syze(in2) ^= 1) go to force;
     138                  end if;
     139
     140              nextop = in1;  $ set next operation.
     141              in1 = 0;  in2 = 0;  $ show no operands.
     142              opc = ip_or;   if  (negfl) opc = ip_and;
     143 $            go to build;  $ add operation to tree.
     144
     145
     146          elseif  opc = do_and then  $ logical and case.
     147              $   this is similar to the -or- case above.
     148              if  dout(in1) = 0 then   $ first input not deferred.
     149                  if  (syze(in1) ^= 1) go to force;
     150                  end if;
     151
     152              if  dout(in2) = 0 then   $ second input not deferred.
     153                  if  (syze(in2) ^= 1) go to force;
     154                  end if;
     155
     156              nextop = in1;  $ set next operation.
     157              in1 = 0;  in2 = 0;  $ show no operands.
     158              opc = ip_and;  if  (negfl) opc = ip_or;
     159 $            go to build;  $ add operation to tree.
     160
     161
     162          elseif  opc = do_not then  $ logical not operation.
     163              $   in the case of a -not- opertation, simply set the
     164              $   negate flag and apply de morgan's laws.  also set
     165              $   a flag in the last operation added to the tree so that
     166              $   when back up past it on the way up, the negate flag
     167              $   can be toggled to its previous status.
     168              if  dout(in1) = 0 then   $ first input not deferred.
     169                  if  (syze(in1) ^= 1) go to force;
     170                  end if;
     171
     172              negfl = .not. negfl;  $ negate 'negate' flag.
     173              if  (lptr)  it_negfl it(lptr) = .not. it_negfl it(lptr);
     174              nextop = in1;  go to next;  $ continue but dont add op.
     175
     176
     177          elseif  opc >= do_lt & opc <= do_ne then  $ is comparison.
     178              $   this is the most common, complex, and important case.
     179              $   want to check the operands of the comparison.
     180              $   first, though, will test to see if this is a
     181              $   comparison of a one-bit item with either zero or one
     182              $   or any item with zero.
     183              $   if it is, then it is either a -not- or a noop and
     184              $   can be processed accordingly.
     185              until  yes;  $ exit if not special.
     186                  if  (opc ^= do_eq & opc ^= do_ne) quit until;
     187
     188                  $   for simplicity, want to set the constant
     189                  $   operand to the second operand so swap if not
     190                  $   that way already.
     191                  if  in1 = one ! in1 = zero then  $ swap.
     192                      t = in1;  in1 = in2;  in2 = t;
     193                  elseif  in2 ^= zero & in2 ^= one then
     194                      quit until;  $ this is not special.
     195                      end if;
     196
     197                  if  ((syze(in1) ^= 1 & in2 = one) ! ismw(in1))
     198                      quit until;   $ this is not special.
     199
     200                  nextop = in1;  $ get next operation.
     201
     202                  $   see if this is a -not-.  if so, do the negation.
     203                  if  (opc = do_eq) .ex. (in2 ^= zero) then
     204                      negfl = .not. negfl;  $ negate the negate flag.
     205                      if  (lptr) it_negfl it(lptr) = ^it_negfl it(lptr);
     206                      end if;
     207                  go to next;  $ go down chain.
     208                  end until;
     209
     210              $   check for none of the following special cases.
     211              $   1   convert  a<1  to  0 >= a
     212              $   2   convett  a>= 1  to  0 < a
     213              if  in2 = one & (opc = do_lt! opc = do_ge)  then
     214                  in2 = in1;  in1 = zero;  $ change operands.
     215                  opc = (do_lt + do_ge) - opc;  $ switch operation
     216                  end if;
     217              $   otherwise have a normal comparison.  first, compute
     218              $   the branch mask.
     219              bmask = bmasks(opc - (do_lt-1));  $ get normal mask.
     220              if  (negfl)  bmask = binv(bmask);  $ invert if negated.
     221
     222              $   check operands of the comparison.
     223              if  (dout(in1) ! dout(in2))  go to force;  $ normal.
dsk  308              if  (ismw(in1) ! ismw(in2))  go to force; $ if multi-word.
     224                  $   this is a normal comparison.  all must do
     225                  $   is check for a comparison against zero and, if so,
     226                  $   ensure it is the second operand.  then the
     227                  $   comparison operation can be built.
     228                  if  in1 = zero then  $ first input is zero.
     229                      in1 = in2;  $ set to nonzero input.
     230                      in2 = 0;  $ show this is zero.
     231                      bmswap(bmask, t);   $ swap the branch mask.
     232                  elseif  in2 = zero then  $ second input is zero.
     233                      in2 = 0;  $ flag as such.
     234                      end if;
     235
     236                  nextop = 0;  $ show to go back.
     237                  opc = ip_cmp;  $ add operation.
     238          else   $ not special operation.
     239              go to force;   $ so force evaluation.
     240              end if;
     241
     242 /build/
     243
     244
     245          $   first, add variables to -iv- table.
     246          if  (ivptr > ivmax-2) go to force;  $ overflow.
     247          iv(ivptr+1) = in1;  iv(ivptr+2) = in2;  $ insert.
     248          ivptr = ivptr + (in1^=0) + (in2^=0);  $ increment.
     249
     250          if  (itptr > itmax-1) go to force;  $ tree is full.
     251
     252          itval = 0;  $ clear entry.
     253
     254          $   build the node for the tree.
     255          it_op    itval = opc;  $ set opcode.
     256          it_dop   itval = optr;  $ set operation pointer.
     257          it_blink itval = lptr;  $ set back link.
     258          it_bmask itval = bmask;  $ set branch mask.
     259          it_inp1  itval = in1;  $ set first input.
     260          it_inp2  itval = in2;  $ set second input.
     261
     262          itptr = itptr+1;  it(itptr) = itval;  $ insert into tree.
     263
     264
     265          $   see about updating pointer to this node.
     266          if  lptr then  $ if this is not root.
     267              if  it_rlf it(lptr) = left   $ see which to update.
     268                  then    it_llink it(lptr) = itptr;  $ left.
     269                  else    it_rlink it(lptr) = itptr;  end if;  $ right.
     270              end if;
     271
     272          lptr = itptr;  $ set last node pointer.
     273
     274 /next/   $   merge here to advance to next operation.
     275          if  nextop = 0 then  $ this means back up the tree.
     276              lptr = it_blink it(lptr);  $ step back the tree.
     277              while  lptr;  $ loop while someplace to go.
     278                  negfl = negfl .ex. it_negfl it(lptr);  $ flip switch.
     279
     280                  it_negfl it(lptr) = no;  $ clear switch.
     281                  $   see whether are in left or right subtree
     282                  $   of the ancestor node.
     283                  if  it_rlf it(lptr) = left then  $ are in left.
     284                      $   in this case, merely move to the right
     285                      $   subtree.
     286                      it_rlf it(lptr) = right;  $ set to right subtree.
     287                      nextop = dp_inp2 dops(it_dop it(lptr)); $ next.
     288                      go to next;  $ go process that op or variable.
     289
     290                  else    $   are in the right subtree.
     291                      $   in this case must back up to the ancestor
     292                      $   of this node.  but first must do two
     293                      $   things.  the first is to set the status back
     294                      $   to left for the second pass.
     295                      it_rlf it(lptr) = left;
     296
     297                      $   the second thing is to update the count of
     298                      $   the number of nodes below this one.  in
     299                      $   addition, if the left subtree has more nodes
     300                      $   than the right subtree, they are swapped.
     301                      it_count it(lptr) =
     302                          it_count it(it_llink it(lptr)) +
     303                          it_count it(it_rlink it(lptr));
     304
     305                      if  it_count it(it_llink it(lptr)) >
     306                          it_count it(it_rlink it(lptr)) then  $ swap.
     307                          t = it_llink it(lptr);
     308                          it_llink it(lptr) = it_rlink it(lptr);
     309                          it_rlink it(lptr) = t;
     310                          end if;
     311
     312                      lptr = it_blink it(lptr);  $ back up to try again.
     313                      end if;
     314                  end while;
     315
     316              $   if reach here, then are done with the first
     317              $   pass.
     318              quit while;  $ exit from first pass.
     319
     320
     321          elseif  dout(nextop) = 0 then
     322              $   in this case the next 'operation' is actually
     323              $   a variable.  so must build an operation which
     324              $   compares it against zero.
     325              dophold = 0;  $ this is zero also.
     326              opc = ip_cmp;  in1 = nextop;  in2 = 0;  $ set parms.
     327              bmask = binv(bm_zer);  if  (negfl) bmask = bm_zer;
     328              nextop = 0;  go to build;  $ add to tree.
     329
     330          else
     331              $   this is the case where the next operation is
     332              $   really an operation.
     333              dophold = dout(nextop);  optr = dophold;  $ set index.
     334              end if;
     335          end while;
     336
     337
     338
     339
     340      $   this is the end of the first pass.
     341
     342      $   before the second pass is started, must go through
     343      $   the variable table and indicate the using status.  then the
     344      $   initial input and the dummy zero and one can be dropped so
     345      $   that only the variables that will actually be used are shown
     346      $   as being used.
     347      do  i = 1 to ivptr;  $ loop over the whole table.
     348          using(iv(i));   $   increment the count.
     349          end do;
     350
     351      kill(zero);  kill(one);  kill(dopir);  $ drop junk.
     352
     353
     354
     355      $   are ready to begin the second pass.  first must
     356      $   assign the labels for the root of the tree depending on the
     357      $   original operation code.
     358      if  dopcode = do_if then
     359          it_tlab it(1) = 1;
     360          it_flab it(1) = 2;
     361      else    $   must be -ifnot- so invert.
     362          it_tlab it(1) = 2;
     363          it_flab it(1) = 1;
     364          end if;
     365
     366
     367      itptr = 1;  $ start traverse at root of tree.
     368      while  itptr;  $ while not done with tree.
     369          $   first extract values from node.
     370          itval = it(itptr);   $ get copy of node.
     371          opc = it_op itval;  $ get operation code.
     372          in1 = it_inp1 itval;  in2 = it_inp2 itval;  $ inputs.
     373          bmask = it_bmask itval;
     374
     375          $   get target label.  will use the lower of the two
     376          $   label indices.
     377          lab = it_tlab itval;  $ assume true is lower.
     378          if  lab > it_flab itval then  $ it is in fact higher.
     379              lab = it_flab itval;  $ set to false label.
     380              bmask = binv(bmask);  $ invert branch mask.
     381              end if;
     382
     383          $   if this is neither and -and- nor an -or- and a label
     384          $   has not been assigned to the index, must assign one
     385          $   now.
     386          if  opc ^= ip_and & opc ^= ip_or & il(lab) = 0 then
     387              labget(t);  $ get a label;
     388              il(lab) = t;   $ put it into the table.
     389              end if;
     390
     391          lab = il(lab);  $ get the actual label number.
     392
     393
     394          $   must process the node depending on operation.
     395          if  opc = ip_and ! opc = ip_or then  $ logical ops.
     396              $   in this case all must do is to update the true
     397              $   and false labels of the sons of the node.  in all
     398              $   cases the right son gets the same labels.  however,
     399              $   the left son gets a new label for either true or false
     400              $   depending on the operation.
     401              it_tlab it(it_rlink itval) = it_tlab itval;
     402              it_flab it(it_rlink itval) = it_flab itval;
     403
     404              $   initially copy both labels to left son also.
     405              it_tlab it(it_llink itval) = it_tlab itval;
     406              it_flab it(it_llink itval) = it_flab itval;
     407
     408              countup(ilptr, ilmax, 'il');  $ get a label index.
     409              il(ilptr) = 0;  $ clear entry to show unassigned.
     410
     411              if  opc = ip_and then  $ assign to true label.
     412                  it_tlab it(it_llink itval) = ilptr;
     413                  it_tdef it(it_llink itval) = yes;  $ show definer.
     414              else    $ must be -or-.
     415                  it_flab it(it_llink itval) = ilptr;
     416                  it_fdef it(it_llink itval) = yes;
     417                  end if;
     418
     419
     420          elseif  opc = ip_cmp then
     421              $   this is either a simple comparison or a test.
     422              if  in2 then  $ this is comparison.
     423                  lastuse(in1);  lastuse(in2);  $ set status.
     424                  cmp_op(bmask, in1, in2, lab);
     425              else    $ this is just test.
     426                  lastuse(in1);   $ set status.
     427                  if_op(bmask, in1, lab);
     428                  end if;
     429
     430
     431              end if;
     432
     433
     434          $   if have just done a forward branch must set a flag
     435          $   to indicate that can no longer put items into registers
     436          if  lab .ne. 0 & lab .ne. il(1)  then  $ if must set
     437              isinif = yes;  $ set flag for emitbin and emitcmp.
     438              end if;
     439          $   go down the left branch until hit end.
     440          lptr = it_llink itval;  $ get left pointer.
     441          if  lptr then  $ will continue down.
     442              itptr = lptr;  $ set to son.
     443              cont while;  $ continue.
     444              end if;
     445
     446
     447 /loop/   $   merge here to back up tree.
     448
     449          $   go back up the tree.
     450          itptr = it_blink it(itptr);  $ go back up.
     451          if  (itptr = 0) quit while;   $ done when hit top.
     452
     453          $   see if are in the left or right subtree of that
     454          $   node.
     455          if  it_rlf it(itptr) = left then  $ were in left subtree.
     456              $   in this case set to right subtree.
     457              it_rlf it(itptr) = right;  $ set for next time.
     458              itptr = it_rlink it(itptr);  $ go to the right.
     459              cont while;  $ process it.
     460
     461          else    $ were in right subtree.
     462              $   in this case must actually define any labels
     463              $   that were flagged as being defined in this node and
     464              $   that were used.  then back up the tree again.
     465              lab = 0;  $ assume no label to define.
     466              if  (it_tdef it(itptr)) lab = it_tlab it(itptr);
     467              if  (it_fdef it(itptr)) lab = it_flab it(itptr);
     468
     469              $   see if there was a label to define and if it
     470              $   was used.
     471              if  lab then  $ a label was defined.
     472                  if  il(lab) then  $ it was also used.
     473                      labdef(il(lab), no);  $ define at this point.
     474                      labfree(il(lab));  $ free the label.
     475                      il(lab) = 0;   $ clear just to be sure.
     476                      end if;
     477                  end if;
     478
     479              go to loop;   $ back up again.
     480              end if;
     481          end while;
     482
     483
     484
     485          isinif = no;  $ reset flag for emit level routines.
     486      $   are done with both passes.  all that remains is to
     487      $   define the initial 'true' label if it has been used.
     488      if  il(2) then  $ it has been used.
     489          labdef(il(2), no);   $ define the label.
     490          labfree(il(2));  $ free the label.
     491          end if;
     492
     493
     494      dophold = 0;  $ show nothing to evaluate.
     495      return;
     496
     497 /force/
     498      $   this is branched to in order to force evaluation of
     499      $   something.  this will pick the best thing to force
     500      $   evaluation of (as far down the tree as possible.)
     501
     502      kill(one);  kill(zero);   $ first, drop constants.
     503
     504      if  (dophold) return;  $ if something here, done.
     505
     506      dophold = optr;  $ else set to last operation.
     507      if  (dophold) return;  $ if something here, done.
     508
     509      dophold = dout(dopir);  $ else set to initial operation.
     510      return;
     511
     512      macdrop(it_op)      macdrop(it_tlab)
     513      macdrop(it_flab)    macdrop(it_dop)
     514      macdrop(it_llink)   macdrop(it_rlink)
     515      macdrop(it_bink)    macdrop(it_count)
     516      macdrop(it_bmask)   macdrop(it_inp1)
     517      macdrop(it_inp2)    macdrop(it_off1)
     518      macdrop(it_off2)    macdrop(it_len)
     519      macdrop(it_tdef)    macdrop(it_fdef)
     520      macdrop(it_negfl)   macdrop(itsz)
     521      macdrop(itmax)      macdrop(ivmax)
     522      macdrop(ilmax)      macdrop(ip_or)
     523      macdrop(ip_and)     macdrop(ip_cmp)
     524      macdrop(left)
     525      macdrop(right)
     526
     527      end subr asmif;
     528 ..ifopt
       1 .=member asmlong
       2      subr asmlong;  $ call off-line multi-word routine.
       3      $   this routine processes multi-word simple operations by
       4      $   generating calls to off-line routines.
       5      size  aop(ps);   $ operation to issue.
       6      size  dop_comparison(do_not);  $ flags comparison ops.
       7      data  dop_comparison = 1b'00000 00011 1100';
       8
       9      dopsname = longname(dopcode);  $ get routine name.
      10      callnodrop = yes;  $ dont drop parameters.
      11
      12      if  dopnargs = 1 then  $ unary operation.
      13          dopxr(1) = dopir;  $ first is input.
      14          if  dopcode = do_not then  $ this is subroutine call.
      15              assignconst(dopxr(2), syze(dopir)) $ length.
      16              dopnx = 3; $ three parameters.
      17              dopxr(3) = dopor;  $ third is output.
      18              call_op;  $ call routine.
      19          else  $ this is a call to library function.
      20              assignconst(dopxr(2), nwords(dopir)) $ length of input.
      21              forcezero(0, no);   $ clear register zero.
      22              dopnx = 2; call_op;  $ call with two parameters.
      23              inzero(dopor, no);  $ indicate output in r0.
      24              end if;
      25
      26      else   $ must be binary operation.
      27
      28          $   insert first four operands for call.
      29          dopxr(1) = dopir; assignconst(dopxr(2), nwords(dopir))
      30          dopxr(3) = dopjr; assignconst(dopxr(4), nwords(dopjr))
      31          $   comparison operation are functions, so check if this
      32          $   is a comparison operation.
      33          if  .f. dopcode, 1, dop_comparison  then  $ if comparison.
      34              dopnx = 4;  $ only four arguments.
pic   13              forcezero(0,no);  $ clear register zero
      35              call_op;  $ call routine.
      36              inzero(dopor, no);  $ show in r0.
      37          else    $ normal binary operation.  output is last argument.
      38              dopnx = 5;  $ has five arguments.
      39              dopxr(5) = dopor;  $ fifth is output.
      40              call_op;  $ call routine.
      41              end if;
      42          end if;
      43
      44      end subr asmlong;
       1 .=member asmfld
       2      subr asmfld(fb, len, var, source);  $ prepare for .f. op.
       3      $   this routine emits the code for all the .f.
       4      $   operations.  it first checks that all inputs are validly
       5      $   deferred.  then it processes constant length and position
       6      $   and sets up index and position registers where aplicable.
       7      size  fb(ps);           $ register containing bit position.
       8      size  len(ps);          $ register containing field length.
       9      size  var(ps);          $ register containing .f. variable.
      10      size  source(ps);       $ register containing source of assignment
      11      size  t1(ps), t2(ps);   $ temporaries.
      12      size  i(ps);             $ temporary
      13      size  isaop(1);         $ 'this is assignment operation'
      14      size  isxop(1);         $ 'this is indexed operation'
      15      size  ismwop(1);        $ 'this is multi-word operation'
      16      size  work(ps), work1(ps), work2(ps);   $ work registers.
      17      size  mode(ps);          $ machine mode for target word.
      18      size  mreg(ps);          $ machine register for target word.
      19      size  moff(mosize);      $ machine offset for target word.
      20      size  mreg1(ps);         $ temporary machine register.
      21
      22      $   first, set flags for operation type.
      23
      24      isxop = (dopcode = do_xfasin);
      25
      26      isaop = isxop ! (dopcode = do_fasin);
      27
      28      ismwop = ismw(var);   $ set multi-word attribute.
      29
      30
      31      $   set flags and value for constant length and position.
      32      doplenconst = isscon(len);    $ constant length flag.
      33      doplenval = conval(len);      $ value of constant length.
      34
      35      dopfbconst = isscon(fb);      $ constant position flag.
      36      dopfbm1val = conval(fb) - (conval(fb)^=0);
      37
      38
      39 .+defer.
      40      $   ensure that all inputs are validly deferred.
      41      dophold = dout(fb);   $ first check bit position.
      42      if  dophold then   $ it is deferred.
      43          if  (dp_op dops(dophold) ^= do_add) go to ret;  $ must be add.
      44          t1 = dp_inp1 dops(dophold);  t2 = dp_inp2 dops(dophold);
      45          until  yes;   $ ensure that at least one is constant.
      46              dopfbm1 = t2;  $ assume inp1 is constant.
      47              if  (conval(t1) = 1) quit until;  $ exit if it is.
      48              dopfbm1 = t1;  $ assume inp2 is constant.
dsd   17              if  (conval(t2) = 1) quit until;  $ exit if it is.
      50              go to ret;  $ else cannot defer this input.
      51              end until;
      52
      53          dopfbconst = isscon(dopfbm1);  $ reset constant and
      54          dopfbm1val = conval(dopfbm1);  $ value flags.
      55          end if;
      56
      57      $   if this is an indexed operation, check the index.
      58      if  isxop then  $ this is indexed.
      59          call asmdxchk(dopkr);  $ index is kept there.
      60          if  (dophold) go to ret;  $ force evaluation if needed.
      61          end if;
      62
      63      dophold = dout(var);  $ check variable (always zero or asin).
      64      if  dophold then  $ this is deferred.
      65          if  di_ldrop ditem(dr_item dreg(var)) = no !
      66              di_count ditem(dr_item dreg(var)) ^= 1 then
      67              if  (ismwop) go to ret;
      68              end if;
      69
      70          if  (dp_op dops(dophold) ^= do_xload) go to ret;  $ not valid.
      71          $   call routine to check if the operands to this indexed
      72          $   load are validly deferred.
      73          call asmdxchk(dp_inp2 dops(dophold));  $ check index.
      74          if  (dophold) go to ret;  $ not validly deferred.
      75          end if;
      76
      77
      78 .+eab.
      79 $ [the desired code here is, for s37, to emit ni, tm, and oi
      80 $ which clear target bit, skip if source bit off, and if
      81 $ source bit on, then -or- constant one in to effect move   20 apr]
      82      $   do special check for the case of a field move of one bit.
      83      if  source then   $ this may be a special case.
      84          dophold = dout(source);   $ see if source is deferred.
      85          if  dophold then  $ it is.
      86              if  (doplenval ^= 1) go to ret;  $ not one bit asign.
      87              if  (dopfbconst = no) go to ret;  $ not constant position.
      88              if  (dp_op dops(dophold) ^= do_fext) go to ret;
      89              if  (conval(dp_inp2 dops(dophold)) ^= 1) go to ret;
      90              if  (isscon(dp_inp1 dops(dophold)) = no) go to ret;
      91              $   must be carefull that this is never a field
      92              $   move from a field to the same field because in that
      93              $   case the clear of the bit would be done before the
      94              $   test of the bit.  since it is not simple to compare
      95              $   both arrays, will compare the bit positions.
      96              if  (dopfbm1val = conval(dp_inp1 dops(dophold)) - 1)
      97                  go to ret;  $ cannot have this as special case.
      98              dophold = dout(dp_inp3 dops(dophold));
      99              if  (dophold) go to ret;   $ cannot have index.
     100              isspecial = yes;  $ show this is a special case.
     101              end if;
     102          end if;
     103 ..eab
     104
     105      $   if reach here, the operands were validly deferred, so
     106      $   clear -dophold-.
     107      dophold = 0;
     108 ..defer
     109
     110      $   process position to do subtraction if needed.
     111      if  dopfbconst then  $ this is constant.
     112          kill(fb);  $ can drop constant register.
     113          assignconst(dopfbm1, dopfbm1val);  $ set new constant.
     114 .+defer.
     115      elseif  dout(fb) then  $ this was an addition of one.
     116          using(dopfbm1);  kill(fb);  $ reset status.
     117 ..defer
     118      else    $ must subtract one.
     119          getdreg(dopfbm1);  $ get result register.
     120          lastuse(fb);  $ set status.
     121          sub1_op(dopfbm1, fb);  $ do the subtraction.
     122          end if;
     123
     124      $   process the variable and index.  first, initialize.
     125      dopvar = var;  dopindx = 0;  $ original variable, no index.
     126 .+defer.
     127      if  dout(var) then   $ this is indexed load so set new items.
     128          dopvar = dp_inp1 dops(dout(var));  $ get base.
     129          dopindx = dp_inp2 dops(dout(var));  $ get index.
     130          using(dopvar); using(dopindx); kill(var);  $ set status.
     131          end if;
     132 ..defer
     133
     134      doff = nwords(dopvar);   $ set initial word offset.
     135      $   if this is an indexed operation, set index.
     136      if  isxop then  $ this is indexed operation.
     137          dopindx = dopkr;  $ this is where index is kept.
     138 .+defer.
     139          end if;
     140
     141      $   if there is an index register, position it and
     142      $   compute possible new offset.
     143      if  dopindx then  $ there is an index register.
     144 ..defer
     145          call asmxload(dopvar, dopindx);  $ position index.
     146          end if;
     147
     148
     149      ismwop = ismw(dopvar);  $ reset multi-word flag.
     150
     151      $   are ready to use the bit position to build the
     152      $   correct index value to access the desired word.
     153      $   this is only done if the variable is multi-word.
     154      if  ismwop  then  $ get new index.
     155          $   if constant position, just compute new word index.
     156          if  dopfbconst then   $ this is constant position.
     157              doff = doff - dopfbm1val/mws;
     158              dopfbm1val = mod(dopfbm1val, mws);   $ to place in word.
vaxa 197              kill(dopfbm1);   $ drop old value.
vaxa 198              assignconst(dopfbm1, dopfbm1val);  $ get new one.
     159          else    $ must compute index register.
vaxa 199 .+t10        assignconst(work2, mws);  $ get constant.
vaxa 200 .+t10        getdreg(work);  lastuse(work2);
vaxa 201 .+t32        getdreg(work);
     162              if  doplenval = mws then  $ need not keep values.
     163                   lastuse(dopfbm1);  $ set status.
     164                  end if;
     165
vaxa 202 .+t10        div_op(work, dopfbm1, work2);
vaxa 203 .+t32        assignconst(work2, 5);  lastuse(work2);
vaxa 204 .+t32        div2_op(work, dopfbm1, work2);
vaxa 205 .+t32        assignconst(work2, 2);  $ set to log2 (mcpw).
vaxa 206 .+t32        mul2_op(work, work, work2);  $ shift over again.
     167
     168              if  doplenval ^= mws then  $ must compute new fb
     169                  $   compute bit position mod ws.
     170                  getdreg(work1);  $ get a result register.
vaxa 207 .+t10            assignconst(work2, mws);  $ get word size.
vaxa 208 .+t32            assignconst(work2, mws-1);  $ get word size.
     172                  lastuse(dopfbm1);  lastuse(work2);  $ set status.
vaxa 209 .+t10            mod_op(work1, dopfbm1, work2);  $ get offset.
vaxa 210 .+t32            and_op(work1, dopfbm1, work2);  $ get offset.
     174                  dopfbm1 = work1;  $ set new position.
     175                  end if;
     176
     177              $   must compute final offset.  must get a new
     178              $   register and either negate or subtract.
     179
     180              getdreg(work1);  lastuse(work);
     181
     182              if  dopindx then  $ must subtract two registers.
     183                  lastuse(dopindx);    $ set status.
     184                  sub_op(work1, dopindx, work);  $ do subtract.
     185              else    $ just negate offset.
     186                  neg_op(work1, work);  $ do negation.
     187                  end if;
     188
     189              dopindx = work1;  $ set to new index register.
     190              end if;
     191          end if;
     192
     193
vaxa 211 .+t10.
     194 /*
     195      the following is the code skeletons for field ops.
     196      the code sequences for field extraction and insertion
     197      are very similar, as shown below by parenthesized comments
     198      indicating code for field insertion.
     199      r = .f. c1+1, c2, ea   (or .f. c1+1, c2, ea = r)
     200          lpr  r,ea,c1,c2  (or  spr  r,ea,c1,c2)
     201
     202      r = .f. c, e, ea     (or .f. c, e, ea = r)
eaa  132          lda*  ra,ea
     204          ldwi rb,c-1
     205          spr  rb,ra,30,6  set p
     206          ldw  rb,e
     207          spr  rb,ra,24,6  set s
     208          ldf  r,ra        (or stf r,ra)
     209
     210      r = .f. e, c, ea     (or .f. e, c, ea = r)
eaa  133          lda*  ra,ea
     212          ldwi rb,c
     213          spr  rb,ra,24,6  set s
     214          iso  rb,e
     215          spr  rb,ra,30,6  set p
     216          ldf  r,ra        (or stf r,ra)
     217
     218      r = .f. e1, e2, ea   (or .f. e1, e2, ea = r)
eaa  134          lda*  ra,ea
     220          iso  rb,e1
     221          spr  rb,ra,30,6  set p
     222          ldw  rb,e2
     223          spr  rb,ra,24,6  set s
     224          ldf  r,ra        (or stf r,ra)
     225
eaa  135  instances of lda* denote lda except for extended addressing (t20),
eaa  136  where lla op is implied.
     226 */
vaxa 212 ..t10
vaxa 213
vaxa 214
     227      if  dopindx then    $ must set lastuse flags.
     228          lastuse(dopvar);  lastuse(dopindx);
     229          end if;
     230
     231      i = gw_word;  if  (isaop)  i = gw_addr;
eaa  137 .+t20.  $ if possible dynamic heap reference.
eaa  138      if  nsheap_this  then
eaa  139          $ need special getword call to defer address load if
eaa  140          $ reference to heap. we are adding an oracle so getword
eaa  141          $ can tell us if doing assignment to indexed heap variable.
eaa  142          asmflh_gwi = 1; $ indicate special call
eaa  143          $ set if not constant field length and origin.
eaa  144          asmflh_varext = (1 -dopfbconst & doplenconst);
eaa  145          end if;
eaa  146 ..t20
     232      getwordc(i, dopkr, dopvar, doff, dopindx);  $ get needed word.
     233
eaa  147 .+t20.  $ see if need special code for dynamic heap reference.
eaa  148      if  nsheap_this then
eaa  149          asmflh_gwi = 0; $ indicate endof special call
eaa  150      else
eaa  151          asmflh_gwo = 0;
eaa  152          end if;
eaa  153 ..t20
     234      $   see if this is a full word operation.  if so
     235      $   just move in the word.
     236      if  doplenval = mws then  $ it is.
     237          kill(len);   $ kill constant length.
     238          lastuse(dopkr);  $ set last use of target word.
     239          if  isaop then  $ this is an assignment.
     240              lastuse(source);  $ set status.
     241              move_op(dopkr, source);  $ move the word.
     242          else    $ this is an extraction.
     243              lastuse(dopor);  $ set status.
     244              move_op(dopor, dopkr);  $ move into output.
     245              end if;
     246
     247          go to ret;   $ done in this case.
     248          end if;
     249
vaxa 215 .+t10.
     250      if  doplenconst & dopfbconst  then  $ if both constant.
     251          kill(len);  kill(dopfbm1);  $ kill constants.
     252          lastuse(dopkr);  $ show last use on target word.
     253          if  isaop then  $ if is assignment.
     254              lastuse(source);  $ set status.
     255              spr_op(source, dopkr, dopfbm1val, doplenval);
     256          else    $   this is field extract.
     257              lastuse(dopor);  $ set status.
     258              lpr_op(dopor, dopkr, dopfbm1val, doplenval);
     259              end if;
     260
     261          go to ret;    $ done
     262          end if;
     263
     264
     265      $   in this case we have the more general field extract or assign
     266      $   when either the offset or length is an expression.  in this
     267      $   case, we must build a byte pointer and then issue an -ldf- or
     268      $   -stf- operation to do the extract or assign.
     269
     270      $   first, load the address of the desired target word into a
     271      $   machine register to use as a byte pointer.
     272      getdreg(work);  $ get dummy register for byte pointer.
     273
     274      $   if wanted word is a short constant which is not in a register,
     275      $   must get its address in the base block.
     276      i = gd_use;  $ default type is gd_use.
     277      if  (isscon(dopkr) & dr_reg dreg(dopkr) = 0) i = gd_addr;
     278      mreg = dr_reg dreg(dopkr);
     279      if  lastdrop(dopkr)  then  $ if last use.
     280          if  mreg  then
     281              if  rl_type reglis(mreg) = rt_need  then
     282                  reglis(mreg) = 0;  $ free register.
     283                  dr_reg dreg(dopkr) = 0;
     284                  mreg = 0;
     285                  end if;
     286              end if;
     287          end if;
     288      if  mreg & isaop  then
     289          rl_subtype reglis(mreg) = rt_live;
     290          end if;
     291      getdesc(dopkr, i, mode, mreg, moff);  $ get address.
     292
     293      getreg(mreg1, rt_live);  $ get register for byte pointer.
eaa  154 .-t20.
     294      emop(mo_lda, mreg1, mode, mreg, moff);  $ get address into reg.
eaa  155 .+t20.
eaa  156        if asmflh_gwo>0 & isaop then
eaa  157            emop(mo_hbc, mreg1, mode, mreg,moff);
eaa  158        else
eaa  159            emop(mo_lla, mreg1,mode, mreg,moff);
eaa  160        end if;
eaa  161        asmflh_gwo = 0;
eaa  162 ..t20
     295      if  (mode=am_reg & isaop)  rl_hold reglis(mreg) = yes;
     296      rl_content reglis(mreg1) = work;  $ show owner of data.
     297      dr_reg dreg(work) = mreg1;  $ show in machine register.
     298
     299      $   now insert position and length into byte pointer.
     300      if  dopfbconst & dopfbm1val = 0 then   $ special case.
     301          kill(dopfbm1);  $ get rid of constant of zero.
     302      else  $ normal case.
     303          lastuse(dopfbm1);  $ show last use of position.
     304          spr_op(dopfbm1, work, 30, 6);  $ set p field.
     305          end if;
     306
     307      if  doplenconst & doplenval = 0 then  $ special case.
     308          kill(len);    $ done with constant length.
     309      else  $ normal case.
     310          lastuse(len);  $ show last use of length.
     311          spr_op(len, work, 24, 6);  $ set s field.
     312          end if;
     313
     314
     315      $   now do the actual extract or assign.
     316      lastuse(work);  $ show next is last use of byte pointer.
     317      if  isaop then  $ if is assignment.
     318          lastuse(source);  $ set status.
     319          stf_op(source, work);  $ do the assignment.
     320      else    $   this is an extraction.
     321          lastuse(dopor);  $ set status.
     322          ldf_op(dopor, work);  $ do the extraction.
     323          end if;
     324
     325      kill(dopkr);  $ kill the desired word.
vaxa 216 ..t10
vaxa 217 .+t32.
vaxa 218      lastuse(len);  lastuse(dopfbm1);  lastuse(dopkr);  $ set status.
vaxa 219      if  isaop then  $ is field assignment.
vaxa 220          lastuse(source);   $ set status.
vaxa 221          spr_op(source, dopkr, dopfbm1, len);  $ do assign.
vaxa 222      else    $ is field extract.
vaxa 223          lastuse(dopor);  $ set status.
vaxa 224          lpr_op(dopor, dopkr, dopfbm1, len);  $ do extract.
vaxa 225          end if;
vaxa 226 ..t32
     326
     327 /ret/
     328      end subr asmfld;
     329 .+defer.
       1 .=member asmdxch
       2      subr  asmdxchk(index);  $ check for valid index deferral.
       3      size  index(ps);        $ index to check.
       4      size  in1(ps), in2(ps); $ inputs to operation.
       5
       6      dophold = dout(index);  $ see if index is deferred.
       7      if  dophold  then  $ if so, process.
       8          $   the index can only be deferred if it is an addition
       9          $   of a constant.
      10          until  yes;  $ quit if ok.
      11              in1 = dp_inp1 dops(dophold);  in2 = dp_inp2 dops(dophold);
      12              if  dp_op dops(dophold) = do_add then  $ may be ok.
      13                  if  (isscon(in1)) quit until;  $ this is ok.
      14                  if  isscon(in2) then  $ this is ok too.
      15                      dp_inp1 dops(dophold) = in2;  $ switch to simplify
      16                      dp_inp2 dops(dophold) = in1;  $ job of -asmxload-.
      17                      quit until;  $ show is ok.
      18                      end if;
      19                  end if;
      20
      21              return;  $ else must evaluate.
      22              end until;
      23
      24          dophold = 0;  $ otherwise, show ok.
      25          end if;
      26
      27      end subr asmdxchk;
      28 ..defer
       1 .=member asmxld
       2      subr asmxload(base, index);  $ process index for array.
       3      $   this routine processes the index for an array.  it sets up
       4      $   the index to be a machine index into the array.  it will
       5      $   either multiply the index by the appropriate amount or will
       6      $   do a shift of the appropriate amount.  in addition, if the
       7      $   index is a constant or an index plus a constant, the constant
       8      $   will be added to the global variable -doff-.
       9      size  base(ps);         $ base variable (array)
      10      size  index(ps);        $ index.
      11      size  off(ps);          $ temporary offset value.
      12      size  work(ps), work1(ps);  $ temporary registers.
      13      size  t(ps);            $ temporary.
      14
      15      off = 0;  $ initialize offset.
      16
      17 .+defer.
      18      $   if the index is deferred, the it must be constant+new index.
      19      $   so get the constant and the new index.
      20      if  dout(index) then  $ it is.
      21          work = index;  $ save old index.
      22          off = conval(dp_inp1 dops(dout(index)));  $ get offset.
      23          index = dp_inp2 dops(dout(index));  $ get new index.
      24          using(index);  kill(work);  $ set status.
      25          end if;
      26 ..defer
      27
      28      $   if index is a constant, just add in constant.
      29      if  isscon(index) then  $ it is a constant.
      30          off = off + conval(index);  $ add it in.
      31          kill(index);   index = 0;   $ drop index.
      32      else    $ must multiply or shift.
      33          t = nwords(base);   $ get amount to multiply by.
      34          if  (t & (t-1)) = 0 then  $ is a power of two.
vaxa 227 .+t10        if  t^=1  then  $ if not identity.
      36                  getdreg(work);  $ get dummy register.
vaxa 228 .+t10            assignconst(work1, ((.fb.t)-1));
vaxa 229 .+t32            assignconst(work1, ((.fb.t)+1));
      38                  lastuse(work1);  lastuse(index);
      39                  mul2_op(work, index, work1);
      40                  index = work;
vaxa 230 .+t10            end if;
      42
      43          else    $ must multiply.
vaxa 231 .+t10        getdreg(work);  assignconst(work1, t);
vaxa 232 .+t32        getdreg(work);  assignconst(work1, t * mcpw);
      45              lastuse(work1);  lastuse(index);  $ set status.
      46              mul_op(work, index, work1);  $ do multiply.
      47              index = work;  $ set new index.
      48              end if;
      49          end if;
      50
      51      doff = doff + off*nwords(base);  $ set new word offset.
      52
      53      end subr asmxload;
       1 .=member assign
       2      subr assignr(type);  $ assign a dummy register
       3      size  type(ps);   $ encoding of desired argument
       4      size  db(1);      $ holds drop bit
       5      size  var(ps);    $ holds -voa- pointer.
       6      size  i(ps);      $ temporary.
       7      size  di(ps);       $ pointer to dummy item.
       8      size  dw(ps);       $ pointer to dummy word.
       9      size  ditemval(ditemsz), dwordval(dwordsz);  $ temporaries.
      10
      11      $   first, must determine which -voa- entry is wanted.
      12      $   then, the -voa- index and the drop bit are set and the
      13      $   main section of this routine is executed.
      14
      15      $   [ds 11 apr, for efficiency replace else...elseif by goby]
      16      if  type > va_xarg then  $ this is reference to -xarg-.
      17          db = xa_db xarg(vv_argbeg voa(voaep)+type-(va_xarg+1));
      18          var = xa_voa xarg(vv_argbeg voa(voaep)+type-(va_xarg+1));
      19      elseif  type = va_oup then  $ request for output of operation.
      20          db = no; var = vv_oup voa(voaep);
      21      elseif  type = va_inp1 then  $ request for input one.
      22          db = vv_db1 voa(voaep); var = vv_inp1 voa(voaep);
      23      elseif  type = va_inp2 then  $ request for input two.
      24          db = vv_db2 voa(voaep); var = vv_inp2 voa(voaep);
      25      elseif  type = va_inp3 then  $ request for input three.
      26          db = vv_db3 voa(voaep); var = vv_inp3 voa(voaep);
      27      elseif  type = va_inp4  then  $ fourth input (in vv_oup)
      28          db = vv_dboup voa(voaep);  var = vv_oup voa(voaep);
      29      elseif  type = va_fnct then  $ request for function result.
      30          db = yes; var = 1;  $ set to function return.
      31      elseif  type = va_spec then  $ special call.
      32          db = yes; var = voaep;  $ specific variable.
      33      else    $ invalid -assign- call.
      34          call aermey(5);  $ write error message and terminate.
      35          end if;
      36
      37      $   can begin processing the operand.  first, check to
      38      $   see if the operand is already in a dummy register.
      39
      40      if  vv_inreg voa(var) then  $ it is.
      41          $   in this case merely set drop bit status, assign to return
      42          $   variable, and increment count.
      43          di = vv_inreg voa(var);  $ copy register number.
      44          if  (di_lword ditem(di) = 0) call aermey(6); $ error.
      45
      46 .+defer.     $   check if this is re-use of a deferred temporary.
      47          if  type=va_oup & di_temp ditem(di) & di_ldrop ditem(di) then
      48              vv_inreg voa(var) = 0;  $ clear this entry.
rke   10              if  (di_baseblk ditem(di))
rke   11                  bb_bptr baseblock(di_chain ditem(di)) = 0;
      50              go to skip;    $ must get a new value.
      51              end if;
      52 ..defer
      53
      54          $   update status.
      55          di_count ditem(di) = di_count ditem(di)+1;  $ increment count.
      56          di_ldrop ditem(di) = db;  $ set new drop value.
      57          di_luse ditem(di) = 0;  $ show no drop flags yet.
      58
      59          assignreg = dw_freg dword(di_lword ditem(di));  $ get reg.
      60          go to ret;  $ return this value.
      61          end if;
      62
      63 /skip/   $   entered here to get new -dreg-.
      64      $   handle case where the -voa- operand is a constant.   in
      65      $   this case the -assignconst- routine is called to process
      66      $   the constant.  if it is a multi-word constant, then it is
      67      $   processed as a normal variable.
      68
rkb   19      if  vv_const voa(var) & vv_syze voa(var) <= scs
      70          & tmctab(vv_lextype voa(var)) <= tmc_b  then  $ if safe.
rkb   20          $ have a short constant.  must set special
rkb   21
      72          $   flags for -assignconst- to indicate that the size of
      73          $   the constant is known and also that is already in -val-
      74          $   array.  then pass the -val- index rather than the
      75          $   constant itself to -assignconst-.
      76          asconstspc = yes;  $ show special case.
      77          asconstdb = db;  $ copy over drop bit.
      78          asconstsz = vv_syze voa(var);  $ get size.
      79          asconstreal = vv_amode voa(var);  $ set mode.
      80          assignconst(assignreg, vv_vbeg voa(var));  $ assign constant.
      81          go to ret;  $ return value.
      82          end if;
      83
      84      $   have a normal case which will be handled in this
      85      $   routine.  first must obtain dummy values from the free
      86      $   list and then fill in the appropriate fields.
      87
      88      di = ditemfree;  $ get off free list.
      89      if  (di = 0) call aermey(7);  $ error if full.
      90      ditemfree = di_out ditem(di);  $ restore chain.
      91
      92      dw = dwordfree;  $ get off free word list.
      93      if  (dw = 0) call aermey(8);  $ error if full.
      94      dwordfree = dw_next dword(dw); $ restore chain.
      95
      96      assignreg = dregfree;  $ get off register list.
      97      if  (assignreg = 0) call aermey(9);  $ error if full.
      98      dregfree = dr_next dreg(assignreg);  $ restore free chain.
      99
     100      ditemval = 0;  dwordval = 0;  $ clear values.
     101
     102      vv_inreg voa(var) = di;  $ point -voa- to item.
     103
     104      $   fill in common fields in -ditem-.
     105      di_syze ditemval = vv_syze voa(var);  $ get size.
     106      di_mw ditemval = (vv_syze voa(var) > mws);  $ multi-word flag.
     107      di_nwords ditemval = (vv_syze voa(var) + (mws-1))/mws;
     108      di_real ditemval = vv_amode voa(var);  $ arithmetic mode.
     109      di_temp ditemval = vv_temb voa(var);  $ temporary bit.
     110      di_var ditemval = (vv_temb voa(var) = no);  $ since not constant.
     111      di_array ditemval = (vv_dimn voa(var)^=0)&(vv_const voa(var)=no);
     112      di_ldrop ditemval = db;  $ set drop bit.
     113      di_count ditemval = 1;  $ show just this one use.
     114      di_anum ditemval = vv_argno voa(var);  $ get argument number.
     115      di_lword ditemval = dw;  $ point to -dword-.
     116
     117      $   set fields in -dword-.
     118      dw_freg dwordval = assignreg;  $ set first register.
     119      dw_word dwordval = di_nwords ditemval;  $ set word position.
     120      if  (di_array ditemval)    $ must update word position.
     121          dw_word dwordval = (di_nwords ditemval)*2;
     122
     123      $   process single-word temporaries.
     124      if  di_temp ditemval & di_mw ditemval = no then  $ this case.
     125          $   if not output is error.
     126          if  (type ^= va_oup) call aermey(31);  $ terminal error.
     127
     128          $   otherwise, allocate space in temporary block.
     129          baseprobenc(i, 1, bt_temp, yes);  $ i --> temporary.
     130          bb_pointer baseblock(i) = no;  $ show no longer free.
     131          bb_bptr baseblock(i) = var;  $ point back to -voa-.
     132          di_chain ditemval = i;  $ point to base block.
     133          di_baseblk ditemval = yes;  $ show in vase block.
     134          di_mblk ditemval = bl_base;  $ set machine block.
     135          dw_madr dwordval = bb_addr baseblock(i);  $ set address.
     136
     137      else    $ multi-word temporary or variable.
     138          di_chain ditemval = var;  $ point to -voa-.
     139          di_mblk ditemval = vv_mblk voa(var);  $ get machine block.
     140          dw_madr dwordval = vv_madr voa(var);  $ get machine address.
     141      if  (di_anum ditemval)  dw_madr dwordval = 1;
     142          end if;
     143
     144      $   finally, plant all values in table.
     145      ditem(di) = ditemval;  dword(dw) = dwordval;
     146
     147      dreg(assignreg) = 0;  $ clear dummy reg.
     148      dr_word dreg(assignreg) = dw;  $ point to dummy word.
     149      dr_item dreg(assignreg) = di;  $ point to dummy item.
     150
     151 /ret/    $   return register.
     152 .+trace.     $   generate trace code.
     153      if  trace_d then  $ if tracing enabled.
     154          tintl('assign var', var) tintl('to', assignreg) endl
     155          end if;
     156 ..trace
     157
     158      end subr assignr;
       1 .=member asconst
       2      subr asconst(value);  $ assign register to constant.
       3      size  value(ws);  $ value to assign to register.
       4      size  valp(ps);   $ pointer to -val- array.
       5      size  hcode(mws/2);$ hash code in -baseblock-.
       6      size  i(ps);      $ index.
       7      size  ditemval(ditemsz), dwordval(dwordsz);  $ temporaries.
       8      size  di(ps);       $ pointer to dummy item.
       9      size  dw(ps);       $ pointer to dummy word.
      10
      11      $   the first thing that must be done is to set various parameters
      12      $   these are size of constant, index into -val- of constant,
      13      $   and drop bit value for constant.  normally, these are
      14      $   calculated from the constant itself.  however, when the
      15      $   flag -asconstspc- is set, it indicates that this call is
      16      $   from -assignr- and thus these parameters have already been
      17      $   set.  in the latter case, the flag is reset.
      18
      19      if  asconstspc then  $ this is internal call.
      20          valp = value;  $ value passed is index into -val-.
      21          asconstspc = no;  $ clear special case flag.
      22      else    $ normal call.
      23          asconstsz = (.fb. value) + (value=0);  $ compute size.
      24          countup(valptr, valdim, 'val');  $ get space in -val-.
      25          valp = valptr; val(valp) = value;  $ set into -val- array.
      26          asconstdb = yes;  $ assume last use.
      27          asconstreal = no;  $ assume integer value.
      28          end if;
      29
      30      $   must place constant into -baseblock-.  the hash code
      31      $   is computed by exclusive-or'ing the two half-words of the
      32      $   constant.
      33
      34      hcode = .f. 1,mws/2, val(valp) .exor. .f.mws/2+1,mws/2, val(valp);
      35
      36      $   insert into table, if not already present, by use of
      37      $   -baseprobe- macro to search hashed table.
      38      baseprobe(i, hcode, 1, bt_const, valp, ar_val, valptr);
      39
      40      $   handle case where constant is already in dummy register.
      41      if  bb_bptr baseblock(i) then  $ it is.
      42          di = bb_bptr baseblock(i);  $ get item pointer.
      43          di_count ditem(di) = di_count ditem(di)+1;  $ increment count.
      44          di_ldrop ditem(di) = asconstdb;  $ set drop flag.
      45          di_luse ditem(di) = 0;  $ show no drop flags yet.
      46          asconstreg = dw_freg dword(di_lword ditem(di)); $ get -dreg-.
      47          go to ret;  $ go return register.
      48          end if;
      49
      50      $   in the other case, get a dummy item, word, and register
      51      $   from the free lists and initialize them.
      52
      53      di = ditemfree;  $ get a dummy item.
      54      if  (di = 0) call aermey(7);  $ error if none.
      55      ditemfree = di_out ditem(di);  $ restore free chain.
      56
      57      dw = dwordfree;  $ get word from free chain.
      58      if  (dw = 0) call aermey(8);  $ error if all being used.
      59      dwordfree = dw_next dword(dw);  $ restore free chain.
      60
      61      dwordval = 0; ditemval = 0;  $ clear values.
      62
      63      $   if the address is assigned, copy it.
      64      if  bb_addr baseblock(i) then  $ it is assigned.
      65          di_mblk ditemval = bl_base;  $ show in base block.
      66          dw_madr dwordval = bb_addr baseblock(i);  $ set machine addr.
      67          end if;
      68
      69      $   initialize common fields in dummy values.
      70      di_chain ditemval = i;  $ point to base block.
      71      di_baseblk ditemval = yes;  $ show in base block.
      72      di_syze ditemval = asconstsz;  $ set size.
      73      di_const ditemval = yes;  $ show is constant.
      74      di_nwords ditemval = 1;  $ this routine only handles 1-word.
      75      di_real ditemval = asconstreal;  $ set mode.
      76      di_lword ditemval = dw;  $ point to last word item.
      77      di_count ditemval = 1;  $ show just this one user.
      78      di_ldrop ditemval = asconstdb;  $ set drop bit.
      79
      80      $   check for short constants.
      81      if  asconstsz <= mps then  $ this is short.
      82          di_scon ditemval = yes;  $ show is short constant.
      83          di_cval ditemval = val(valp);  $ set short value.
      84          end if;
      85
      86      $   initialize some fields in word value.
      87      dw_word dwordval = 1;  $ show which word is being referenced.
      88
      89
      90      $   grab a dummy register.
      91      asconstreg = dregfree;  $ get from free list.
      92      if  (asconstreg = 0) call aermey(9);  $ error if none.
      93      dregfree = dr_next dreg(asconstreg);  $ restore list.
      94
      95      $   can point dummy word to dummy register.
      96      dw_freg dwordval = asconstreg;  $ point first in chain.
      97
      98      $   plant all values in tables.
      99      dword(dw) = dwordval;  ditem(di) = ditemval;
     100      dreg(asconstreg) = 0;  $ clear dummy register.
     101
     102      $   set up chains from dummy register.
     103      dr_word dreg(asconstreg) = dw;   $ point to dummy word.
     104      dr_item dreg(asconstreg) = di;   $ point to dummy item.
     105
     106      bb_bptr baseblock(i) = di;  $ finally, point base block to item.
     107
     108 /ret/    $ have register to return.
     109 .+trace.     $ trace code.
     110      if  trace_d then  $ request trace code.
     111          tintl('asconst val', val(valp)) tintl('to', asconstreg) endl
     112          end if;
     113 ..trace
     114
     115      return;
     116      end subr asconst;
       1 .=member clearr
       2      subr clearr(reg);  $ clear a dummy register.
       3      size  reg(ps);  $ register to clear.
       4      size  i(ps), j(ps);  $ temporary indexes.
       5
       6      $   do a check to ensure that things haven't gotten messed up.
       7      if  (istemp(reg)) call aermey(12);
       8
       9
      10      $   must drop any registers that contain data for other
      11      $   words of the item if multi-word.
      12      if  ismw(reg) then   $ must check other words.
      13          i = di_lword ditem(dr_item dreg(reg));  $ get first in chain.
      14          while  i;  $ while more words to loop over.
      15              if  i ^= dr_word dreg(reg) then   $ skip original word.
      16                  j = dw_freg dword(i);  $ point to first register.
      17                  if  dr_reg dreg(j) then  $ must drop register.
      18                      reglis(dr_reg dreg(j)) = 0;  $ drop.
      19                      dr_reg dreg(j) = 0;  $ show not in register.
      20                      end if;
      21                  end if;
      22
      23              i = dw_next dword(i);  $ get next word in chain.
      24              end while;
      25          end if;
      26
      27
      28
      29 .+defer.   $ only needed if deferring.
      30      $   if register is output of deferred operation, that operation
      31      $   was never used so flush it.
      32      if  dout(reg) then  $ must flush operation.
      33          dropdop(dout(reg));  $ flush operation.
      34          dout(reg) = 0;  $ clear field.
      35          end if;
      36 ..defer
      37
      38      $   if a register has been assigned to the register, free it
      39      $   unless it has been permanently assigned.
      40      if  dr_reg dreg(reg) then  $ must drop machine register.
      41          if  rl_perm reglis(dr_reg dreg(reg)) = no & spcdrop = no then
      42              reglis(dr_reg dreg(reg)) = 0;  $ drop machine register.
      43              dr_reg dreg(reg) = no;  $ show not in register.
      44              end if;
      45          end if;
      46
      47 .+trace  if  trace_d then   tintl('*clear', reg) endl end if;
      48
      49      end subr clearr;
       1 .=member dropr
       2      subr dropr(arg);  $ drop a -dreg- or -dop-.
       3      $   this routine is called by the -drop- or -dropdop- macros.
       4      $   if it is called to drop a register, the -drop- macro does
       5      $   nothing unless the last use bit is set.  this routine then
       6      $   checks if the value is dead (count=1 & last drop set).  if so,
       7      $   it frees the item.  otherwise, it merely decrements the usage
       8      $   count.
       9
      10      $   when this routine is called by the -dropdop- macro, it will
      11      $   add the -dop- to the free chain and recursively free the
      12      $   operands of the operation.
      13      size  arg(ps);          $ argument (-dreg- or -dop-)
      14      size  i(ps), j(ps), k(ps);  $ temporaries.
      15      size  reg(ps);          $ -dreg- pointer.
      16      size  di(ps);           $ -ditem- pointer.
      17
      18 .+defer.     $ additional code for dererring.
      19      $   if deferring is being used, this routine is recursive.  t
      20      $   therefore, a stack is used to list all the -dreg-'s that must
      21      $   be dropped.  a loop is then entered until the stack is empty.
      22      size  stack(ps); dims stack(20);   $ the stack.
      23      size  stackp(ps);       $ pointer into -stack-.
      24      size  dop(ps);          $ index into -dops-.
      25
      26      +*  push(d) =  $ push onto stack.
      27          stackp = stackp+1;  $ up pointer.
      28          stack(stackp) = d; **  $ add onto stack.
      29
      30      +*  pop(d) =   $ pop from stack.
      31          d = stack(stackp);  $ read data.
      32          stackp = stackp-1; **  $ decrement pointer.
      33
      34      +*  exit = cont while stackp;  **  $ recursive exit.
      35
      36      $   initialize stack and contents.
      37      stackp = 0;  $ initially empty stack.
      38      if  dropdopflg then  $ this is -dop-.
      39          dropdopflg = no;  $ reset flag.
      40          dop = arg;  $ set index.
      41          go to procdop;  $ go process -dop-.
      42          end if;
      43
      44      push(arg);  $ push first -dreg- onto stack.
      45
      46      $   loop until the stack is empty.
      47      while  stackp;  $ done when nothing more to drop.
      48          pop(reg);   $ get first thing to do from stack.
      49 .-defer.     $ generate code for non-deferrings.
      50      +*  exit = return; **   $ process exit code.
      51
      52          reg = arg;  $ set thing to drop.
      53 ..defer
      54
      55          $   can just return if this was a freed dummy register.
      56          if  (dr_item dreg(reg) = 0) exit;  $ done in this case.
      57
      58 .+trace.     $ generate trace code.
      59          if  trace_d then  $ print trace info.
      60              tintl(' drop, reg', reg) endl
      61              end if;
      62 ..trace
      63
      64          $   see if must drop or just decrement count.
      65          if  di_count ditem(dr_item dreg(reg)) ^= 1 !
      66              di_ldrop ditem(dr_item dreg(reg)) = no ! spcdrop then
      67              $   must decrement count and last usage.
      68              di = dr_item dreg(reg);  $ get item number.
      69              if  (di_luse ditem(di)) di_luse ditem(di) =
      70                  di_luse ditem(di) - 1;
      71              di_count ditem(di) = di_count ditem(di) - 1;
      72              if  (spcdrop) di_ldrop ditem(di) = no;
      73              exit;   $ done with this case.
      74              end if;
      75
      76          $   otherwise, must actually drop register.
      77
      78
      79          $   drop all forms.
      80          di = dr_item dreg(reg);  $ point to dummy item.
      81          i = di_lword ditem(di);   $ get last dummy word.
      82          while  i;  $ loop over each word.
      83              j = dw_freg dword(i);  $ get first form in word.
      84              $   see if must store any live.
      85              if  di_var ditem(di) then  $ is variable.
      86                  if  dr_reg dreg(j) then  $ it is in a register.
      87                      if  (rl_perm reglis(dr_reg dreg(j)))
      88                          call aermey(32);  $ this is an error.
      89                      if  (rl_type reglis(dr_reg dreg(j)) = rt_live)
      90                          store(dr_reg dreg(j), j);  $ store it.
      91                      end if;
      92                  end if;
      93              dropform(j);  $ drop this form.
      94
      95              j = dw_next dword(i);  $ get next word in chain.
      96
      97              $   drop that current word.
      98              dword(i) = 0;  $ clear it.
      99              dw_next dword(i) = dwordfree;  dwordfree = i;  $ free it.
     100              i = j;  $ set to next word.
     101              end while;
     102
     103          $   drop any live address for this item.
     104          if  (di_addrreg ditem(di)) reglis(di_addrreg ditem(di)) = 0;
     105
     106          $   if this is not a constant or temporary and it is
     107          $   chained to the -voa-, clear the -voa- pointer to this
     108          $   dummy item.
     109          if  di_chain ditem(di) then  $ there is a chain.
     110              i = di_chain ditem(di);   $ get pointer.
     111              if  di_baseblk ditem(di) then  $ in base block.
     112                  if  di_temp ditem(di) then  $ free temporary.
     113                     bb_pointer baseblock(i) = yes;
     114                     if  bb_bptr baseblock(i) then $ if points to voa
     115                          $   check that this pointer in fact points
     116                          $   to the dummy item that are freeing.
     117                          if  (vv_inreg voa(bb_bptr baseblock(i)) = di)
     118                              vv_inreg voa(bb_bptr baseblock(i)) = 0;
     119                          end if;
     120                      end if;
     121                  bb_bptr baseblock(i) = 0;  $ clear base block pointer
     122              else    $ in -voa-.
     123                  $   check that clear the correct pointer
     124                  if (vv_inreg voa(i) = di) vv_inreg voa(i) = 0;
     125                  end if;
     126              end if;
     127
     128 .+defer  dop = di_out ditem(di);   $ set if this is output.
     129
     130          $   finally free dummy item.
     131          ditem(di) = 0;   $ clear all status info.
     132          di_out ditem(di) = ditemfree;  $ point this to free chain.
     133          ditemfree = di;  $ put this on free chain.
     134
     135 .+defer  if  (dop = 0)    $ only quit if no deferred output.
     136              exit;   $ quit this drop call.
     137
     138
     139          $   process the dropping of a deferred operation..  first
     140          $   push any registers that this used onto the stack of work
     141          $   to be done.  then free this operation.
     142 /procdop/
     143 .+trace.
     144      if  trace_o then  $ print output.
     145          tintl('drop, dop', dop) endl
     146          end if;
     147 ..trace
     148
     149          go to n(dp_nargs dops(dop)) in 1 to 3;  $ get number to drop.
     150
     151 /n(3)/   push(dp_inp3 dops(dop));
     152 /n(2)/   push(dp_inp2 dops(dop));
     153 /n(1)/   push(dp_inp1 dops(dop));
     154
     155          $   actually free this deferred operation.
     156          dp_chain dops(dop) = dopfree;  $ set this to free chain.
     157          dopfree = dop;  $ put this onto free chain.
     158          end while;   $ loop around again.
     159
     160      macdrop(push)       macdrop(pop)
     161 ..defer
     162
     163      macdrop(exit)
     164
     165      end subr dropr;
       1 .=member dmpdreg
       2 .+trace.
       3      subr dumpdregs;   $ dump dummy registers.
       4      $   this routine is used for tracing purposes to print out
       5      $   the contents of the dummy items, words, and registers.
       6      size  i(ps);        $ index.
       7      size  ditemmap(ditemdim), dwordmap(dworddim), dregmap(dregdim);
       8      size  ditemval(ditemsz),  dwordval(dwordsz),  dregval(dregsz);
       9
      10
      11      $   first print dummy items.  see which are on free chain.
      12      i = ditemfree;  $ point to free chain.
      13      ditemmap = 0;   $ show none initially free.
      14      while  i;  $ while more on free chain.
      15          if  (.f. i, 1, ditemmap) call aermey(13);  $ dup -ditem-.
      16          .f. i, 1, ditemmap = yes;  $ else set bit to show free.
      17          i = di_out ditem(i);  $ get next in chain.
      18          end while;
      19
      20      $   complement map to show which items are in use.
      21      ditemmap = .not. ditemmap;
      22
      23  if  ditemmap  then
      24      $   print title.
      25      endl textl(' dummy items') endl endl
      26      textl(' n b chain s m r a t c v l syze count nwrds luse '
      27          !! 'lwrd mblk') endl
      28
      29      $   print each dummy item.
      30      while  ditemmap;  $ while more to print.
      31          i = .fb. ditemmap;  $ get index to print.
      32          intlp(i, 2)   $ print index.
      33          ditemval = ditem(i);  $ get values.
      34
      35          $   print header information.
      36          intlp(di_baseblk ditemval,2)
      37          intlp(di_chain ditemval, 6) intlp(di_scon ditemval, 2)
      38          intlp(di_mw ditemval, 2)    intlp(di_real ditemval, 2)
      39          intlp(di_array ditemval, 2)
      40          intlp(di_temp ditemval, 2)  intlp(di_const ditemval, 2)
      41           intlp(di_var ditemval, 2)
      42          intlp(di_ldrop ditemval, 2)
      43          intlp(di_syze ditemval, 5)
      44          intlp(di_count ditemval, 6)   intlp(di_nwords ditemval, 6)
      45          intlp(di_luse ditemval, 5)    intlp(di_lword ditemval, 5)
      46          intlp(di_mblk ditemval, 5)
      47
      48          $   print out any special values.
      49          if  (di_scon ditemval) then
      50              textl(' cval ') octl(di_cval ditemval)
      51              end if;
      52          if  (di_addrreg ditemval) tintl('addrreg',di_addrreg ditemval)
      53 .+defer  if  (di_out ditemval) tintl('out', di_out ditemval)
      54          if  (di_anum ditemval) tintl('anum', di_anum ditemval)
      55
      56          .f. i, 1, ditemmap = no;  $ show done with register.
      57          endl
      58          end while;
      59  else  textl('no dummy items')  endl  end if;
      60
      61      $   print dummy words.
      62      dwordmap = 0;  $ show none in use yet.
      63      i = dwordfree;  $ start at head of free chain.
      64
      65      while  i;  $ while some in free chain.
      66          if  (.f. i, 1, dwordmap) call aermey(14);  $ dup -dword-.
      67          .f. i, 1, dwordmap = yes;  $ else show free.
      68          i = dw_next dword(i);  $ point to next in chain.
      69          end while;
      70
      71      $   complement map to get words in use.
      72      dwordmap = .not. dwordmap;
      73
      74 if  dwordmap  then
      75      $   print title.
      76      endl endl textl(' dummy words') endl endl
      77      textl('  n next madr freg word') endl
      78
      79      while  dwordmap;  $ while more in use.
      80          i = .fb. dwordmap;  $ get first in list.
      81          intlp(i, 3)  $ print out index.
      82          dwordval = dword(i);  $ get value.
      83
      84          $   print out values.
      85          intlp(dw_next dwordval, 5)  intlp(dw_madr dwordval, 5)
      86          intlp(dw_freg dwordval, 5)
      87          intlp(dw_word dwordval, 5)
      88
      89          .f. i, 1, dwordmap = no;  $ show this not in use.
      90          endl
      91          end while;
      92  else  textl('no dummy words')  endl  end if;
      93
      94
      95      $   process dummy registers.
      96      dregmap = 0;  $ show none free yet.
      97      i = dregfree;  $ point to head of free chain.
      98
      99      while  i;  $ loop over free chain.
     100          if  (.f. i, 1, dregmap)  call aermey(15);  $ dup -dreg-.
     101          .f. i, 1, dregmap = yes;  $ show on free chain.
     102          i = dr_next dreg(i);  $ get next on chain.
     103          end while;
     104
     105      $   invert map to get registers in use.
     106      dregmap = .not. dregmap;
     107
     108  if  dregmap  then
     109      $   print titles.
     110      endl endl textl(' dummy registers') endl endl
     111      textl('  n next item word reg') endl
     112
     113      $   process each register.
     114      while  dregmap;  $ while more in use.
     115          i = .fb. dregmap;  $ get first to process.
     116          intlp(i, 3);  $ print index.
     117          dregval = dreg(i);  $ get register value.
     118
     119          $   print information.
     120          intlp(dr_next dregval, 5)   intlp(dr_item dregval, 5)
     121          intlp(dr_word dregval, 5)
     122          intlp(dr_reg dregval, 4)
     123          if  (dr_next dregval)  call aermey(21);
     124
     125          .f. i, 1, dregmap = no;  $ show done this one.
     126          endl
     127          end while;
     128  else  textl('no registers in use') endl end if;
     129
     130      endl   $ leave a blank line at the end.
     131
     132      end subr dumpdregs;
     133 ..trace
       1 .=member dmpmreg
       2 .+trace.   $ only used if tracing.
       3      subr dumpmregs;  $ dump machine registers.
       4      $   this routine prints a dump of the machine register status
       5      $   for use in debugging.
       6      size  i(ps);        $ loop index.
       7      size  nact(ps);         $ number of active registers.
       8      size  rname(.sds. 4);   $ register names.
       9      dims  rname(rhihi);        $ number of registers.
      10      data  rname =   ' r0 ', ' r1 ', ' r2 ', ' r3 ', ' r4 ',
      11                      ' r5 ', ' r6 ', ' r7 ', ' r8 ', ' r9 ',
vaxa 233 .+t10                'r10 ', 'r11 ', 'r12 ', 'r13 ', 'r14 ',
vaxa 234 .+t32                'r10 ', 'r11 ', 'ap  ', 'fp  ', 'sp  ',
vaxa 235 .+t10                'r15 ';
vaxa 236 .+t32                'pc  ';
      14
      15      size  rtype(.sds. 5);   $ register types.
      16      dims  rtype(rt_permlive+1);  $  number of types +1.
      17      data  rtype(rt_dead+1)     = ' dead':
      18            rtype(rt_need+1)     = ' need':
      19            rtype(rt_address+1)  = ' addr':
      20            rtype(rt_live+1)     = ' live':
      21            rtype(rt_liveaddr+1) = ' ladr':
      22            rtype(rt_permresv+1) = ' resv':
      23            rtype(rt_perm+1)     = ' perm':
      24            rtype(rt_permlive+1) = ' prml';
      25
      26
      27
      28      nact = 0;
      29      do  i = r0 to rhi;  $ loop over all registers.
vaxa 237          if  (reglis(i) = 0) cont do;  $ dont list dead.
      31          nact = nact + 1;
      32          if  nact = 1  then  $ if need title.
      33              endl textl('   machine registers') endl
      34              textl('nam  content type h ah useval') endl
      35              end if;
      36
      37          $   list attributes.
      38          textl(rname(i)) intlp(rl_content reglis(i), 8)
      39          textl(rtype(rl_type reglis(i)+1))
      40          intlp(rl_hold reglis(i), 2) intlp(rl_addrhold reglis(i), 3)
      41          intlp(rl_usevalue reglis(i), 7) endl
      42          end do;
      43
      44
      45      endl    $ leave a blank line.
      46      end subr dumpmregs;
       1 .=member endblk
       2 ..trace
       3      subr endblock;  $ end a basic block.
       4      $   this routine is called by -asmprog- when a basic block is to
       5      $   be ended.  this routine drops all registers except those
       6      $   which only need be dropped when a label is encountered.
       7      size  i(ps);        $ do loop index.
       8      size  reg(ps);      $ -dreg- pointer.
       9
      10      $   if the -reissuedop- flag is on, this routine just returns
      11      $   because it will be called again.
      12 .+defer  if  (reissuedop) return;
      13
      14 .+trace  if  trace_a then  textl(' *endblock') endl end if;
      15
      16      do  i = r0 to rhi;
      17          if  (rl_perm reglis(i)) cont do;  $ skip permanent.
      18          if  (rl_type reglis(i) = rt_dead) cont do;  $ ignore dead.
      19          if  (rl_type reglis(i) = rt_address) cont do;  $ leave addr.
      20
      21          $   know that have a register which either contains
      22          $   data or a live address.  drop the appropriate
      23          $   type.
      24          if  rl_type reglis(i) = rt_liveaddr then  $ error.
      25              call aermey(30);  $ cannot have this at block end.
      26          else    $   must be a data type.
      27              dr_reg dreg(rl_content reglis(i)) = 0;  $ clear pointer.
      28              end if;
      29
      30          reglis(i) = 0;  $ drop register.
      31          end do;
      32
      33      end subr endblock;
       1 .=member forcer
       2      subr forcer(reg, flg);  $ force a variable to register zero.
       3      $   this routine is called by the macro -forcezero-.  it puts
       4      $   either a variable or the address of a variable into register
       5      $   zero.
       6      size  reg(ps);          $ variable to force into register zero.
       7      size  flg(1);           $ set if address wanted in r0.
       8      size  t(ps);            $ temporary.
       9      size  mode(ps);            $ mode.
      10      size  mreg(ps);         $ machine register.
      11      size  moff(mosize);         $ machine offset.
      12      size  mnam(ps);
      13 .+trace.
      14      if  trace_a then  $ trace output wanted.
      15          tintl('force, reg', reg) tintl('fl', flg) endl
      16          end if;
      17 ..trace
      18
      19      $   clear register zero before putting anything into it.
      20      if  rl_type reglis(r0) ^= rt_dead then  $ must do it.
      21          getreg(t, rl_type reglis(r0));  $ get new register.
      22          if  t  then  $ register available.
      23              reglis(t) = reglis(r0);  $ copy status.
      24              mrcopy(t, r0);  $ copy regs.
      25              end if;
      26          dr_reg dreg(rl_content reglis(r0)) = t;  $ set new owner.
      27          reglis(r0) = 0;  $ free register zero.
      28          end if;
      29
      30      $   if -reg- is given as zero, this was a call just to clear
      31      $   register zero.
      32
      33      if  (reg = 0)   return;
      34
      35      $   first, check to see whether the address or data is wanted
      36      $   in register zero.
      37      if  flg then   $ address wanted in register zero.
      38          $   get the descriptor for the last word.
      39          getdesc(dw_freg dword(di_lword ditem(dr_item dreg(reg))),
      40              gd_addr, mode, mreg, moff);  $ get machine values.
      41          emop(mo_lda, r0, mode, mreg, moff);
      42
      43      else    $   want variable itself in register.
      44          mreg = r0;  $ set to get into r0.
      45          getvar(reg, gd_inregnu, mode, mreg, moff);  $ load to register
      46          end if;
      47
      48      drop(reg);      $ free if last use.
      49
      50      end subr forcer;
       1 .=member getdreg
       2      subr getdregr(dr);   $ get a new dummy register.
       3      size  dr(ps);           $ register obtained.
       4      size  dw(ps);           $ pointer to dummy word.
       5      size  di(ps);           $ pointer to dummy item.
       6      size  bbp(ps);          $ base block pointer.
       7      size  ditemval(ditemsz), dwordval(dwordsz);  $ temporaries.
       8
       9      $   first get a new dummy item, word, and register.
      10      di = ditemfree;   $ get from free list.
      11      if  (di = 0) call aermey(7);  $ none left.
      12      ditemfree = di_out ditem(di);   $ rechain.
      13
      14      dw = dwordfree;  $ get free word.
      15      if  (dw = 0) call aermey(8);  $ none left.
      16      dwordfree = dw_next dword(dw);  $ rechain.
      17
      18      dr = dregfree;  $ get free register.
      19      if  (dr = 0) call aermey(9);  $ none left.
      20      dregfree = dr_next dreg(dr);  $ rechain.
      21
      22      $   initialize values.
      23      ditemval = 0;  dwordval = 0;
      24
      25      $   find an available temporary.
      26      baseprobenc(bbp, 1, bt_temp, yes);   $ scan base block.
      27      bb_pointer baseblock(bbp) = no;  $ show no longer free.
      28
      29      $   fill in fields for -ditem-.
      30      di_chain ditemval = bbp;  $ point to base block.
      31      di_baseblk ditemval = yes; $ show is in base block.
      32      di_syze ditemval = mps;  $ set to one word.
      33      di_nwords ditemval = 1;   $ show one word long.
      34      di_temp ditemval = yes;   $ show is temporary.
      35      di_ldrop ditemval = yes;  $ show this is last use.
      36      di_count ditemval = 1;    $ show just one user.
      37      di_mblk ditemval = bl_base;  $ set machine block.
      38      di_lword ditemval = dw;   $ point to dummy word.
      39
      40      $   set fields for -dword-.
      41      dw_madr dwordval = bb_addr baseblock(bbp);  $ machine address.
      42      dw_word dwordval = 1;  $ show is first word.
      43      dw_freg dwordval = dr;  $ point to first in register chain.
      44
      45      $   replace fields and do final chaining.
      46      ditem(di) = ditemval;  dword(dw) = dwordval;
      47
      48      dreg(dr) = 0;  dr_item dreg(dr) = di;  dr_word dreg(dr) = dw;
      49
      50 .+trace  if  trace_d then  tintl('gotdreg', dr) endl end if;
      51
      52      end subr getdregr;
       1 .=member getword
       2      subr getwordr(out, in, type, offset, index);  $ word/character.
       3      $   this routine is used to address, store, or retrieve a word
       4      $   or character of a multi-word item.
       5      size  out(ps);      $ output dummy register.
       6      size  in(ps);       $ input dummy register.
       7      size  type(ps);     $ type of call.
       8      size  offset(ps);   $ word or character offset.
       9      size  index(ps);    $ register for index.
      10
      11      $   this routine uses a table to define the operations to be
      12      $   performed on the operands.
      13
      14      $   the fields in this table are defined below.
      15
      16      +*  gt_inddr  = .f. 1, 1, **  $ 'drop forms if indexed'
      17      +*  gt_kind   = .f. 3, 2, **  $ kinds of 'output's.
      18      +*  mop_gt    = .f. 9, 8, **  $ machine instruction to issue.
      19
      20      $   kind values for output.
      21
      22      +*  gk_output = 0 **  $ it is a real output.
      23      +*  gk_input  = 1 **  $ it is really an input operand.
      24
      25      +*  num_gk = 1 **
      26
      27      +*  gwt(typ, mop, drp, outk) =  $ build table.
      28          gwtab(typ) = mop*4b'100'+outk*1b'100'+drp **
      29
      30      size  gwtab(ws); dims gwtab(num_gw);  $ define table.
      31      data        $   initialize table.
      32      $         type     mop    drp     kind
      33      $         ----     ---    ---     ----
      34
      35          gwt(gw_word,  mo_ldw,   no,  gk_output):
      36          gwt(gw_addr,  mo_lda,  yes,  gk_output):
      37          gwt(gw_sword, mo_stw,  yes,  gk_input);
      38
      39      macdrop(gwt)
      40
      41      size  woff(ps);     $ word offset.
      42      size  nmadr(ws);    $ new machine address.
      43      size  reg(ps), reg1(ps);  $ temporary -dreg-'s.
      44      size  mreg(ps), mreg1(ps), mreg2(ps);  $ temporary -mreg-'s.
      45      size  moff(mosize);     $ machine offset.
dsj   57      size  moff1(mosize);    $ temporary.
      46      size  mode(ps);     $ machine address type.
      47      size  t(ws), t1(ps);$ dummy variables and temporaries.
      48      size  mop(ps);      $ machine operation to issue.
      49      size  hcode(mws/2);  $ hash code for -baseblock-.
      50      size  di(ps);       $ dummy item index.
      51      size  dw(ps);       $ dummy word index.
      52
eaa  163 .+t20. $ special code for nsheap (extended addressing)
eaa  164      if asmflh_gwi  then  $ if called from asmfld
eaa  165     $ asmflh_gwi nonzero indicates we are being called from asmfld
eaa  166     $ and caller wants to know if assignment target is in dynamic
eaa  167     $ heap.
eaa  168        asmflh_gwo = 0; $ assume not heap reference
eaa  169          end if;
eaa  170 ..t20
      53      woff = offset;  $ copy offset to local variable.
      54
      55      $   now check for the normal case and exit immediately if so.
      56      if (type = gw_addr ! type = gw_word) & nwords(in) = 1 & index = no
      57          & di_array ditem(dr_item dreg(in)) = no then  $ do nothing.
      58          out = in;  $ just copy the word to the output.
      59          go to ret;  $ done.
      60          end if;
      61
      62      $   first, get pointers to dummy item and word.
      63      di = dr_item dreg(in);  dw = dr_word dreg(in);
      64
      65      if di_anum ditem(di) ^= 0 & di_addrreg ditem(di) = 0  then
      66          $   must obtain machine reg with address of rightmost word.
      67          getreg(mreg, rt_liveaddr);  $ get register.
vaxa 238 .+t10    emop(mo_ldw, mreg, am_rel, parmreg, di_anum ditem(di)-1);
vaxa 239 .+t32    moff1 = 0;  mbo_off moff1 = di_anum ditem(di);
vaxa 240 .+t32    emop(mo_ldw, mreg, am_rel, parmreg, moff1);
      69          rl_type reglis(mreg) = rt_address;
      70          rl_content reglis(mreg) = di;
      71          rl_hold reglis(mreg) = yes;
      72          di_addrreg ditem(di) = mreg;
      73          end if;
      74
      75      getdesc(in, gd_addr, mode, mreg, moff);
      76      nmadr = mbo_off moff - (dw_word dword(dw) - woff) + 1;
      77      if  (nmadr<0)  nmadr = mneg(iabs(nmadr));
      78      t = nmadr - 1;
      79      if  (t<0)  t = mneg(iabs(t));
      80      mbo_off moff = t;
      81
      82      $   build a new dummy word for the desired word.
      83      $   first see if it already exists.
      84      t1 = di_lword ditem(di);  $ set to start of chain.
      85      while  t1;  $ while more in chain.
      86          if  dw_word dword(t1) = woff then  $ found what want.
      87              dw = t1; reg = dw_freg dword(dw);  $ set to this one.
      88              quit while;  $ show found.
      89              end if;
      90
      91          t = t1;  $ save last position in chain.
      92          t1 = dw_next dword(t1);  $ point to next.
      93          end while;
      94
      95      $   if hit end of chain, must build new word.
      96      if  t1 = 0 then  $ at end of chain.
      97          dw = dwordfree;  $ get from free chain.
      98          if  (dw = 0) call aermey(7);  $ none left.
      99          dwordfree = dw_next dword(dw);  $ rechain.
     100
     101          $   build new word.
     102          dword(dw) = dword(t);  $ copy most from old.
     103          dw_madr dword(dw) = nmadr;  $ set new address.
     104          dw_word dword(dw) = woff;  $ set to wanted word.
     105          dw_next dword(t) = dw;  $ put into chain.
     106
     107          $ get new dummy register.
     108          reg = dregfree;  $ get from free list.
     109          if  (reg = 0) call aermey(9);  $ none left.
     110          dregfree = dr_next dreg(reg);  $ rechain.
     111
     112          $   chain in new register.
     113          dreg(reg) = 0;  $ set initial values.
     114          dr_item dreg(reg) = di;  dr_word dreg(reg) = dw;
     115          dw_freg dword(dw) = reg;
     116          end if;
     117
     118      $   split up into two cases depending on whether or not
     119      $   an index register is specified.
     120      if  index then  $ have an index register.
     121          $   first, save all 'live' forms.
     122          t = di_lword ditem(di);  $ point to first word in chain.
     123          while  t;  $ while more word.
     124              $   the only form which can be live is the 'primary'
     125              $   form so just check it.
     126              if  dr_reg dreg(dw_freg dword(t)) then  $ in a register.
     127                  $   see if live.
     128                  if  rl_type reglis(dr_reg dreg(dw_freg dword(t))) =
     129                      rt_live then  $ must do the store.
     130                      store(dr_reg dreg(dw_freg dword(t)),
     131                          dw_freg dword(t));  $ store live variable.
     132                      end if;
     133                  end if;
     134              t = dw_next dword(t);  $ get next in chain.
     135              end while;
     136
     137          $   get index value into a machine register.
dsj   58          getvar(index, gd_reg, t, mreg1, moff1);
     139
vaxa 241 .+t10.
     140          $   check if the index register is in r0.  if so,
     141          $   must move it somewhere else.
     142          if  mreg1 = r0 then  $ it is.
     143              getreg(mreg1, rt_live);  $ get a register.
     144              dr_reg dreg(index) = mreg1;  $ set new register.
     145              reglis(mreg1) = reglis(r0);  $ copy status.
     146              reglis(r0) = 0;  $ clear r0.
     147              mrcopy(mreg1, r0);
     148              end if;
vaxa 242 ..t10
     149
     150          $ [rk 24 may  code below can be optimized to do only iad,
     151      $   based on lastuse information.]
     152          if  mode = am_rel  then  $ if relative
     153              getreg(mreg2, rt_liveaddr);
     154              emop(mo_ldw, mreg2, am_reg, mreg1, 0);
     155              emop(mo_iad, mreg2, am_reg, mreg, 0);
     156              reglis(mreg2) = 0;
     157              rl_hold reglis(mreg2) = yes;
     158              mreg = mreg2;
     159          elseif  mode = am_mem  then  $ if in memory.
     160              mreg = mreg1;
     161              mode = am_rel;
     162          else  $ fatal if here
     163              call aermey(35);  $ need correct aermey message.
     164              end if;
     165          $   finally, select operation type by output type.
     166          go to iopk(gt_kind gwtab(type)) in 0 to num_gk;
     167
     168 /iopk(gk_output)/   $ indexed -getword- or -getaddr-.
     169          $   in these cases, the word or address of the desired
     170          $   item will be loaded into a new dummy register.  the
     171          $   result form will have minimal information set because
     172          $   it is only used in a few cases.
     173          getdreg(out);  $ get a dummy register for the output.
     174          isreal(out) = di_real ditem(di);  $ set arithmetic mode.
     175          dw = dr_word dreg(out);  di = dr_item dreg(out);  $ get ptrs.
     176          mop = mop_gt gwtab(type);  $ get machine operation to issue.
     177
     178          $   get appropriate register.
     179          getreg(mreg2, rt_live);  $ get general register.
     180
eaa  171 .+t20.
eaa  172      $ note only load address for indexed field assignment
eaa  173      if mop=mo_lda & nsheap_this & (mbo_blk moff = nsheap_blk) then
eaa  174          $ if assignment to dynamic heap, emit special opcode.
eaa  175          mop = mo_hba;
eaa  176          if (asmflh_varext) mop = mo_hbb;
eaa  177          asmflh_gwo = 1; $ indicate heap reference.
eaa  178          asmflh_mreg = mreg; $ save register.
eaa  179          asmflh_moff = moff; $ save offset.
eaa  180          asmflh_mode = mode; $ save mode.
eaa  181          end if;
eaa  182 ..t20
     181          $   do the operation.
     182          emop(mop, mreg2, mode, mreg, moff);  $ do load or load addr.
     183
     184          $   update the status depending on type.
     185          if  type = gw_addr then  $ update address values.
     186              di_addrreg ditem(di) = mreg2; $ show register.
     187              di_mw ditem(di) = yes;  $ show multi-word.
vaxa 243              rl_type reglis(mreg2) = rt_liveaddr;  $ set reg. type.
     189              rl_content reglis(mreg2) = di;  $ show owner.
     190              dw_madr dword(dw) = 1;  $ show offset of zero.
     191          else    $ this is a value load.
     192              dr_reg dreg(out) = mreg2;  $ show in register.
     193              rl_content reglis(mreg2) = out;  $ show owner.
     194              end if;
     195          go to reti;   $ process common indexed return actions.
     196
     197
     198 /iopk(gk_input)/     $ input operand storeword
     199          $   load input into register.
dsj   59          getvar(out, gd_reg, t, mreg2, moff1);
     201          mop = mop_gt gwtab(type);  $ set op. to issue.
     202          $   do operation.
     203          emop(mop, mreg2, mode, mreg, moff);  $ do store.
     204          go to reti;  $ go do common return.
     205
     206
     207 /reti/   $ common return from indexed operations.
     208          $   if -inddr- flag is set in type table for this operation
     209          $   type, must drop all forms in registers.
     210          if  gt_inddr gwtab(type) then    $ must do drops.
     211              t = di_lword ditem(dr_item dreg(in));  $ start of words.
     212              while  t;  $ while more in chain.
     213                  t1 = dw_freg dword(t);  $ first in register chain.
     214                  if  dr_reg dreg(t1) then  $ is in register.
     215                      reglis(dr_reg dreg(t1)) = 0;  $ free register.
     216                      dr_reg dreg(t1) = 0;  $ show freed.
     217                      end if;
     218                  t = dw_next dword(t);  $ next in word chain.
     219                  end while;
     220              end if;
     221          go to ret;  $ go do common return.
     222
     223      else    $   non-indexed case.
     224
     225          $   go process each operation type.
     226          go to opk(gt_kind gwtab(type)) in 0 to num_gk;
     227
     228 /opk(gk_output)/     $   case where output is a alternate form.
     229          out = reg;  $ just point to the new form.
     230          go to ret;  $   go to common return processing.
     231
     232
     233
     234 /opk(gk_input)/  $   input -- storeword,
     235
     236          $   this is a simple store operation, can just do
     237          $   move to see if should store or keep in register.
     238          move_op(dw_freg dword(dw), out);  $ do store.
     239          return;  $ done -- already dropped.
     240
     241          end if;
     242
     243
     244 /ret/    $   common return processing.
     245      $   at this point, merely issue drop calls for each input
     246      $   or output used.
     247      if  index then  drop(index);  end if;
     248      drop(in);  $ drop input.
     249
     250      $   drop output unless -output- type.
     251      if  gt_kind gwtab(type) ^= gk_output  then  $ can drop output.
     252          drop(out);    $ go drop it.
     253          end if;
     254
     255 .+trace.
     256      if  trace_d then   $ print trace info.
     257          if  type = gw_word ! type = gw_addr then
     258              tintl('gotwordr', out) tintl('offset', offset)
     259              tintl('index', index) endl
     260              end if;
     261          end if;
     262 ..trace
     263
     264      macdrop(gk_output) macdrop(gk_oper) macdrop(gk_input)
     265      macdrop(gk_mask)   macdrop(num_gk)
     266
     267      end subr getwordr;
       1 .=member inzero
       2      subr inzeror(reg, flg);  $ indicate value in register zero.
       3      $   the routine is called by the macro -inzero- to indicate
       4      $   that a value is currenly in register zero.  this is normally
       5      $   called after a function call.  the first parameter is the
       6      $   dummy register describing the operand.  the second parameter
       7      $   is a flag indicating whether or not it is actually the address
       8      $   of the operand.
       9      size  reg(ps);          $ operand contained in register zero.
      10      size  flg(1);           $ set if address is in register zero.
      11      size  mreg(ps);         $ machine register for operand.
      12      size  t(ps);            $ temporary and dummy variable.
      13
      14      $   see if quantity or address of quantity is in register zero.
      15      if  flg then   $ this is case where address is in register.
      16          $   in this case, allocate a register to contain the address
      17          $   and move it from r0.
vaxa 244 .+t10    getreg(mreg, rt_liveaddr);  $ must get a register.
vaxa 245 .+t32    mreg = r0;  $ fake to use this register.
      19          rl_content reglis(mreg) = dr_item dreg(reg);  $ show owner.
      20          di_addrreg ditem(dr_item dreg(reg)) = mreg;  $ point to reg.
      21          t = di_lword ditem(dr_item dreg(reg));  $ point to last word.
      22          if  (t^=dr_word dreg(reg) ! dw_next dword(t)) call aermey(17);
      23          dw_madr dword(t) = 1;  $ reset machine address.
vaxa 246 .+t10    mrcopy(mreg, r0);  $ copy it over.
      25      else    $   data item is in r0.
      26          $   in this case, set the status of the variable to
      27          $   indicate that it is in register zero.
      28          rl_content reglis(r0) = reg;  $ set contents of register.
      29          rl_type reglis(r0) = rt_live;  $ set status.
      30          dr_reg dreg(reg) = r0;  $ point varible to register.
      31          end if;
      32
      33      drop(reg);  $ drop if last use.
      34      end subr inzeror;
       1 .=member labdef
       2      subr labdefr(label, flag);  $ define a label.
       3      $   this routine is called by the -labdef- macro to define the
       4      $   position of a label in code.  if desired, it performs some
       5      $   clearing actions corresponding to the occurance of a label.
       6      $   if branch optimization is enabled, and there are fixup
       7      $   requests pending on the label, they will be emitted.
       8      size  label(ps);        $ label to define.
       9      size  flag(1);           $ set to indicate clearing action wanted.
      10      size  i(ps), j(ps);     $ work variables.
      11      size  reg(ps);          $ temporary -dreg- pointer.
      12
      13 .+trace.  $ generate trace code.
      14      if  trace_a then  $ trace wanted.
      15          tintl('labdef, label', label) tintl('f', flag) endl
      16          end if;
      17 ..trace
      18
      19      $   if flag is set, drop all base registers and register with
      20      $   addresses in them.  in addition, set all permenantly assigned
      21      $   registers to live status.
      22      if  flag then   $ clearing actions wanted.
      23          do  i = r0 to rhi;   $ scan all registers.
      24              if  rl_type reglis(i) = rt_perm then  $ set to live.
      25                  if  (isconst(rl_content reglis(i))) cont do;
      26                  rl_type reglis(i) = rt_permlive;  $ set to live.
      27              elseif  rl_type reglis(i) = rt_address then  $ drop addr.
      28                  di_addrreg ditem(rl_content reglis(i)) = 0;
      29                  reglis(i) = 0;  $ free register.
      30                  end if;
      31              end do;
      32
      33          $   clear register useage counter since all not-permanent
      34          $   register should be empty.
      35          reguseval = 0;  $ clear value for lru allocation.
      36
      37          end if;
      38
      39      put ocsfile ,column(9) ,'lab'
dss   44          ,column(17)
dss   45          ,'l'
dss   46          :(label+lablorg),i(labcol, labcol)
dss   47          ,x(17-labcol)
dss   48          ,column(33) ,tmcscom
dss   49          ,' / l '
dss   50          :(label+lablorg),i(2*labcol-1, labcol, 1)
dss   51          ,' /';
      42      call ocsput(0, 0);  $ put code.
      43      .s. 33, 20, ocs = '';  $ clead ocs.
      44
      45      end subr labdefr;
       1 .=member movadr
       2      subr moveaddr(outr, inr);  $ move an address.
       3      $   this routine is called by -emitdop- to process a multi-word
       4      $   indexed load.  it is used to take the output -dreg- from a
       5      $   -getaddr- and move the address pointed to by it into a
       6      $   register so that it can be set as the output of the load.
       7      size  outr(ps);         $ output register.
       8      size  inr(ps);          $ input register.
       9      size  ildr(1);          $ 'last usage of input'
      10      size  reg(ps);          $ temporary register.
      11      size  mreg(ps);         $ machine register.
      12      size  mreg1(ps);        $ second machine register.
      13      size  moff1(mosize);        $ machine offset.
      14      size  di(ps);           $ pointer to dummy item.
      15      size  mode1(ps);            $ dummy parameter.
      16
      17 .+trace.   $ emit trace code.
      18      if  trace_a then  $ trace wanted
      19          tintl('moveaddr, out', outr) tintl('in', inr) endl
      20          end if;
      21 ..trace
      22
      23 $ [output of getaddr is 'funny temporary' when there is index.
      24 $ [to use it, must get through moveaddr  20 apr]
      25      di = dr_item dreg(inr);  $ get dummy item pointer.
      26
      27      $   first, see if input dummy register has an address in a machine
      28      $   register.  if it does, that address can be moved into a new
      29      $   register.
      30      if  di_addrreg ditem(di) then   $ it is in a machine register.
      31          $   if this is last use of the input and the register is
      32          $   not permanent, then it can be used.
      33          ildr = (di_count ditem(di) = 1 & di_ldrop ditem(di) &
      34              di_luse ditem(di) ^= 0);  $ get last usage status.
      35          if  ildr & rl_perm reglis(di_addrreg ditem(di)) = no then
      36              $   can use this register.  note that need
      37              $   not check if a store is necessary because cannot
      38              $   have a live address for a variable.
      39              mreg = di_addrreg ditem(di);   $ get machine register.
      40              di_addrreg ditem(di) = 0;  $ show not in register.
      41          else    $   must get a new register.
      42              getreg(mreg, rt_liveaddr);  $ go get register.
      43              mrcopy(mreg, (di_addrreg ditem(di)));
      44              end if;
      45
      46      elseif  di_anum ditem(di) then  $ must load address.
      47          call aermey(18);
      48      else    $   must do load address.
      49          getreg(mreg, rt_liveaddr);  $ get register.
      50
      51          $   get base, displacement for value.
      52          getdesc(inr, gd_addr, mode1, mreg1, moff1);
      53
      54          emop(mo_lda, mreg, mode1, mreg1, moff1);
      55          end if;
      56
      57      $   set offset of dummy word.
      58      dw_madr dword(dr_word dreg(outr)) = 1;   $ set machine offset.
      59
      60      $   set output register status.
      61      rl_subtype reglis(mreg) = rt_liveaddr;  $ set to live address.
      62      rl_content reglis(mreg) = dr_item dreg(outr);  $ set to owner.
      63      di_addrreg ditem(dr_item dreg(outr)) = mreg;  $ show in register.
      64
      65      drop(outr); drop(inr);   $ drop operands.
      66
      67      end subr moveaddr;
       1 .=member sdsnam
       2      subr sdsnamr(string, ptr);  $ convert -ha- pointer to sds.
       3      $   this routine is used to convert an -ha- pointer into an
       4      $   sds containing the first -namelen- characters of the
       5      $   name given in the little program.
       6      size  string(.sds. namelen);  $ output string.
       7      size  ptr(ps);                $ -ha- pointer of name to convert.
       8      size  namesp(ps);             $ pointer to -names- array.
       9      size  i(ps);                  $ loop variable.
      10      size  j(ps);                  $ temporary.
vaxa 247 .+t32    size  c(ps);              $ character.
      11
      12      $   first, set length to   max(nchars(ha), namelen)
      13      j = ha_nchars ha(ptr);  $ get length of name.
vaxa 248 .+t10    if (j>6)  j = 6;  $ at most six chars.
vaxa 249 .+t32    if (j>15)  j = 15;  $ at most 15 chars.
      15
      16      $   initialize string descriptor.
      17      string = 0;  $ clear unused parts.
      18      sorg string = .sds. namelen + 1;  $ set origin.
      19      namesp = ha_nayme ha(ptr);  $ get -names- pointer
      20      if  (namesp=0)  j = 0;  $ null string if no name.
      21      slen string = j;
      22
      23      do  i = 1 to j;  $ copy all characters.
      24          .ch. i, string = .f. ws+1-cs - mod(i-1, cpw)*cs, cs,
      25              names(namesp + (i-1)/cpw);  $ move character.
dsp   43 .+t10     if  (.ch. i, string = 1r_)  .ch. i, string = 1r$;
      26          end do;
      27
      28      end subr sdsnamr;
       1 .=member sdlnam
       2      subr sdlnamr(string, ptr);  $ convert -ha- pointer to sds.
       3      $   this routine is used to convert an -ha- pointer into an
       4      $   sds containing the first -namelen- characters of the
       5      $   name given in the little program.
       6      size  string(.sds. namelen);  $ output string.
       7      size  ptr(ps);                $ -ha- pointer of name to convert.
       8      size  namesp(ps);             $ pointer to -names- array.
       9      size  i(ps);                  $ loop variable.
      10      size  j(ps);                  $ temporary.
      11
      12      $   first, set length to   max(nchars(ha), namelen)
      13      j = ha_nchars ha(ptr);  $ get length of name.
      14      if (j>namelen)  j = namelen;  $ at most six chars.
      15
      16      $   initialize string descriptor.
      17      string = 0;  $ clear unused parts.
      18      sorg string = .sds. namelen + 1;  $ set origin.
      19      namesp = ha_nayme ha(ptr);  $ get -names- pointer
      20      if  (namesp=0)  j = 0;  $ null string if no name.
      21      slen string = j;
      22
      23      do  i = 1 to j;  $ copy all characters.
      24          .ch. i, string = .f. ws+1-cs - mod(i-1, cpw)*cs, cs,
      25              names(namesp + (i-1)/cpw);  $ move character.
dsp   44 .+t10     if  (.ch. i, string = 1r_)  .ch. i, string = 1r$;
      26          end do;
      27
      28      end subr sdlnamr;
       1 .=member special
       2      subr special;  $ special case binary operations.
       3      $   this routine check for and processes special cases for
       4      $   simple binary operators.  it sets the global flag -isspecial-
       5      $   to indicate whether or not a special case was found.
       6      $
       7      $   possible special cases are, at present, only those in which
       8      $   one or more of the two operands is a short constant so only
       9      $   these need be processed further.  each operation that can
      10      $   be special cased has two routines.  one is for the case where
      11      $   the right-hand variable is a short constant and the other is
      12      $   for the case where the left-hand variable is a short constant.
      13      $   note that for commutative operations only one of these is
      14      $   necessary and the right-hand one is used.
      15      size  dop_commutes(do_div);  $ flags which operations commute.
      16      data  dop_commutes = 1b'01110001';  $ add, eq, ne, mul commute.
      17      size  aop(ws);          $ a op
      18      size  constv(ws);       $ constant value
      19      size  work(ps);         $ operand pointer
      20      size  t(ps);            $ temporary.
      21
      22      $   initially, not a special case.
      23      isspecial = no;
      24
      25      $   only operations below -do_div- are special cased by this
      26      $   subroutine.
      27      if  (dopcode > do_div) return;
      28
      29      $   if right operand is short constant, process.
      30      if  (isscon(dopjr)) go to right;
      31
      32      $   check left operand.
      33      if  isscon(dopir) then
      34          $   if operation commutes, reverse operands so that right
      35          $   operand will be the constant.  else process left operand.
      36          if  .f. dopcode, 1, dop_commutes then  $ operation commutes.
      37              t = dopir; dopir = dopjr; dopjr = t;  $ swap
      38              go to right;  $ process right operand.
      39          else  $ operation does not commute.
      40              go to left;  $ process left operand.
      41              end if;
      42          end if;
      43
      44      $   since neither operand is a short constant, this is not a
      45      $   special case.
      46      return;
      47
      48 /right/
      49      $   process operand on right-hand side.
      50      constv = conval(dopjr);  $ get constant value.
      51
      52      go to r(dopcode) in do_add to do_div; $ select routine.
      53
      54 /left/
      55      $   process operand on left-hand side.
      56      constv = conval(dopir);  $ get constant value.
      57      go to l(dopcode) in do_add to do_div; $ select routine.
      58
      59
      60
      61 /r(do_add)/
      62      $   special case routine for addition.
      63
      64      if  (constv ^= 1)  return;
      65      isspecial = yes;  $ is special case.
      66      kill(dopjr);  $ kill constant.
      67
      68      lastuse(dopir); lastuse(dopor);  $ set status.
      69      add1_op(dopor, dopir);  $ add one.
      70      return;
      71
      72 /r(do_sub)/
      73      $   special case routine for right-hand constant in subtraction.
      74      $   if constant is not 1, not special.  if it is 1, then use
      75      $   shorter subtraction by 1.
      76      if  (constv ^= 1) return;
      77      isspecial = yes;  $ show special.
      78
      79
      80      kill(dopjr);  $ kill constant input.
      81
      82      lastuse(dopir); lastuse(dopor);  $ set status.
      83      sub1_op(dopor, dopir);  $ subtract.
      84      return;
      85
      86
      87 /r(do_mul)/  /r(do_div)/  $ multiplication, division.
      88      $   if constant is power of two generate appropriate arithmetic
      89      $   shift operation.
      90
      91      if  (.nb. constv ^=1)  return;
      92      if  (dopcode = do_div & syze(dopir) = mws) return;
      93      isspecial = yes;  $ is special case.
      94      assignconst(work, ((.fb. constv)-1));
      95      aop = ao_imt;  $ assume multiplication.
      96      if  (dopcode = do_div)  aop = ao_idt;  $ if division.
      97      lastuse(dopor);  lastuse(dopir);  lastuse(work);  $ set status.
      98      bin_op(aop, dopor, dopir, work);  $ emit op.
      99      return;
     100
     101      $   define unused processors.  these can occur either
     102      $   because a short constant on a given side of an operation
     103      $   does not allow any special case and for the left-hand side
     104      $   of commutative operators.
     105 /l(do_add)/   /l(do_eq)/   /l(do_ne)/   /l(do_mul)/   /l(do_div)/
     106 /l(do_sub)/   /r(do_lt)/   /l(do_lt)/  /r(do_ge)/   /l(do_ge)/
     107  /r(do_eq)/  /r(do_ne)/
     108
     109      end subr special;
       1 .=member storall
       2      subr storall;  $ store all machine registers.
       3      $   this routine stores all live, non-permanent machine registers.
       4      size  i(ps);        $ register index.
       5
       6 .+trace  if  trace_a then   textl(' *storall') endl end if;
       7
       8      do  i = r0 to rhi;  $ loop over all registers.
       9          if  rl_type reglis(i) = rt_live then  $ check if live data.
      10              if  (isvar(rl_content reglis(i)) = no) cont do;
      11              store(i, rl_content reglis(i));  $ store register.
      12              end if;
      13          end do;
      14
      15      end subr storall;
       1 .=member emitbin
       2      subr emitbin(iop, iout, iin1, iin2);  $ emit binary operation.
       3      $   this routine emits binary operations.  it handles much of
       4      $   the lowest-level optimizations done in this code generator.
       5      $   it decides what machine instruction types should be issued
       6      $   for various cases of register status.  it is driven by an
       7      $   internal table which contains information needed for the
       8      $   various sub-routines in this routine.
       9      size  iop(ps);          $ operation.
      10      size  t(mosize);  $ temporary for offset copy.
      11      size  iout(ps);         $ output register.
      12      size  iin1(ps);         $ first input.
      13      size  iin2(ps);         $ second input.
      14
      15      $   operation types used in table.
      16      +*  ek_norm  = 1 **   $ normal binary operation.
      17 .+eab.
      18      +*  ek_mul   = 2 **   $ multiplication.
      19      +*  ek_div   = 3 **   $ division or -mod- function.
      20      +*  ek_sign  = 4 **   $ -sign- or -isign- operation.
      21      +*  ek_shift = 5 **   $ shift right or left.
      22
      23      +*  num_ek = 5 **
      24 .-eab.
      25      +* num_ek = 1 **  $ only norm for
      26 ..eab
      27
      28      size  ebtab(ws);    $ operation table.
      29      dims ebtab(ao_lbo-ao_fbo+1);
      30
      31      $   define fields in -ebtab-.
      32
      33      +*  eb_mop = .f.  1, 8, **  $ machine operation to use.
      34      +*  eb_type = .f.  9, 4, **  $ operation type.
      35      +*  eb_comm = .f. 13, 1, **  $ 'operation commutes'
      36
      37      +*  ebset(op, rm, ty, cm) =  $ build table.
      38          ebtab(op - (ao_fbo-1)) =
      39              cm*4b'1000'+ty*4b'100'+rm **
      40
      41      data   $  initialize binary operation table.
      42
      43 $       aop      r-mop        type    comm
      44 $       ---      -----        ----    ----
      45
      46      ebset(ao_ban,  mo_ban, ek_norm, yes):
      47      ebset(ao_bor,  mo_bor, ek_norm, yes):
      48      ebset(ao_bxo,  mo_bxo, ek_norm, yes):
      49      ebset(ao_idi,  mo_idi, ek_norm, no):
      50      ebset(ao_idt,  mo_idt, ek_norm, no):
      51      ebset(ao_ieq,  mo_ieq, ek_norm, yes):
      52      ebset(ao_ige,  mo_ige, ek_norm, no):
      53      ebset(ao_igt,  mo_igt, ek_norm, no):
      54      ebset(ao_ile,  mo_ile, ek_norm, no):
      55      ebset(ao_ilt,  mo_ilt, ek_norm, no):
dsf    9      ebset(ao_imo,  mo_imo, ek_norm, no):
      57      ebset(ao_imu,  mo_imu, ek_norm, yes):
dsc   11      ebset(ao_imt,  mo_imt, ek_norm, no):
      59      ebset(ao_ine,  mo_ine, ek_norm, yes):
      60      ebset(ao_isi,  mo_isi, ek_norm, no):
      61      ebset(ao_isu,  mo_isu, ek_norm, no):
      62      ebset(ao_iad,  mo_iad, ek_norm, yes):
      63      ebset(ao_rad,  mo_rad, ek_norm, yes):
      64      ebset(ao_rdi,  mo_rdi, ek_norm, no):
      65      ebset(ao_req,  mo_req, ek_norm, yes):
      66      ebset(ao_rge,  mo_rge, ek_norm, no):
      67      ebset(ao_rgt,  mo_rgt, ek_norm, no):
      68      ebset(ao_rle,  mo_rle, ek_norm, no):
      69      ebset(ao_rlt,  mo_rlt, ek_norm, no):
      70      ebset(ao_rmo,  mo_rmo, ek_norm, no):
      71      ebset(ao_rmu,  mo_rmu, ek_norm, yes):
      72      ebset(ao_rne,  mo_rne, ek_norm, yes):
      73      ebset(ao_rsi,  mo_rsi, ek_norm, no):
      74      ebset(ao_rsu,  mo_rsu, ek_norm, no);
      75
      76      macdrop(ebset)
      77
      78      size  op(ps);           $ local copy of operation.
      79      size  out(ps);          $ local copy of output.
      80      size  in1(ps);          $ local copy of first input.
      81      size  in2(ps);          $ local copy of second input.
      82      size  i1ldr(1);         $ 'last usage of input 1'
      83      size  i2ldr(1);         $ 'last usage of input 2'
      84      size  oldr(1);          $ 'last usage of output'
      85      size  omreg(ps);        $ machine register for output.
      86      size  omode(ps);         $ machine indicator for output.
      87      size  omoff(mosize);     $ machine offset for output.
      88      size  i1mreg(ps);       $ machine register for first input.
      89      size  i1mode(ps);        $ machine indicator for first input.
      90      size  i1moff(mosize);       $ machine offset for first input.
      91      size  i2mreg(ps);       $ machine register for second input.
      92      size  i2mode(ps);        $ machine indicator for second input.
      93      size  i2moff(mosize);       $ machine offset for second input.
      94      size  mreg(ps);         $ temporary machine register.
      95      size  mop(ps);          $ temporary operation.
      96      size  lab(ps);          $ label to use.
      97      size  mreg1(ps);        $ second temporary machine register.
      98      size  mreg2(ps);        $ third temporary machine register.
      99      size  i(ps);            $ temporary.
     100
     101 .+trace.   $ print trace info.
     102      if  trace_a then  $ trace info. wanted.
     103          tintl('binop, op', iop) tintl('out', iout)
     104          tintl('in1', iin1) tintl('in2', iin2) endl
     105          end if;
     106 ..trace
     107
     108      $   initialize variable for emission.
     109      op = iop - (ao_fbo-1);  $ get local op code.
     110      out = iout; in1 = iin1; in2 = iin2;  $ get local copy of operands.
     111
     112
     113      $   set last usage indicator for inputs and get machine
     114      $   parameters for them.
     115      i1ldr = lastdrop(in1);  $ get last usage counts.
     116
     117      i2ldr = lastdrop(in2);  $ get last usage counts.
     118
     119      oldr = lastdrop(out);  $ get last usage counts.
     120
     121      getdesc(in1, gd_use, i1mode, i1mreg, i1moff);
dse   17      if  iop = ao_imt ! iop = ao_idt  then $ if mul/div by power of two
dse   18          if  dr_reg dreg(in2) then  $ if input in register.
dse   19              if  (isscon(in2) = no)  call aermey(41);  $ need constant.
dse   20              reglis(dr_reg dreg(in2)) = 0;  $ clear register status.
dse   21              dr_reg dreg(in2) = 0;  $ show no longer in register.
dse   22              end if;
dse   23          end if;
dse   24
dse   25      getdesc(in2, gd_use, i2mode, i2mreg, i2moff);
     123      getdesc(out, gd_use, omode,  omreg,  omoff);
     124
     125      $   branch to proper operation type.
     126 .+eab   go to l(eb_type ebtab(op)) in 1 to num_ek;
     127 .-eab  $ for bootstrap, all ops are ek_norm type.
     128
     129
     130 /l(ek_norm)/    $ processor for normal binary operation.
     131
     132      $   first check for the case where an operand is used for
     133      $   both inputs and the output and the operation is either
     134      $   a subtraction or exclusive-or.  in this case, get a
     135      $   register and assign it to all of the operands.
     136      if  out = in1 & in1 = in2 & omode^=am_reg then  $ have this case.
     137          if  iop = ao_isu ! iop = ao_bxo ! iop = ao_rsu then
     138              omreg = dr_reg dreg(out);  $ see if output register.
     139              if  omreg = 0 then  $ third is not.
     140                  getreg(omreg, rt_live);  $ get register.
     141                  end if;
     142
     143              emop(eb_mop ebtab(op), omreg, am_reg, omreg, 0); $ issue.
     144              go to ret;  $ done.
     145              end if;
     146          end if;
     147
     148      $   the next step is to see if either of the inputs are
     149      $   not in a register but it is not their last use.  in this
     150      $   case, they are loaded into a register, if one is available.
     151
     152      if  i1ldr = no & i1mode^=am_reg & isinif=no then  $ see if can get
     153          $   first, get a register of the appropriate type.
     154          getreg(mreg, rt_need);  $ get real or general.
     155
     156          if  mreg then  $ one is available.
     157              i1mreg = mreg;  $ show register that input will be in.
     158              getvar(in1, gd_intoreg, i1mode, i1mreg, i1moff);  $ load.
     159
     160              if  out = in1 then  $ must update -out- status too.
     161                  omreg = mreg; omode = am_reg;  omoff = 0;
     162                  end if;
     163              if  in2 = in1 then  $ must update -in2- status too.
     164                  i2mreg = mreg; i2mode = am_reg;  i2moff = 0;
     165                  end if;
     166              end if;
     167          end if;
     168
     169      if  i2ldr = no & i2mode^=am_reg & isinif=no then  $ see if can get
     170          getreg(mreg, rt_need);  $ get register.
     171
     172          if  mreg then  $ one is available.
     173              i2mreg = mreg;  $ show operand is in a register.
     174              getvar(in2, gd_intoreg, i2mode, i2mreg, i2moff);  $ load.
     175
     176              if  out = in2 then  $ must update -out- status too.
     177                  omreg = mreg; omode = am_reg;  omoff = 0;
     178                  end if;
     179              end if;
     180          end if;
     181
     182
     183      i = rt_need;  $ set to try to find first time.
     184      while  omode^=am_reg;  $ when exited, register will be in -omreg-.
dsc   15          omoff = 0;
     186
     187          $   if input 1 is in non-permanent register and this is
     188          $   the last use, can use for output.
     189          if  i1ldr & i1mode=am_reg & rl_perm reglis(i1mreg) = no  then
     190              omreg = i1mreg;  $ set output register.
dsc   16              omode = am_reg;
     191              $   must store if live.
     192              if  rl_type reglis(i1mreg)=rt_live & isvar(in1) then
     193                  store(i1mreg, in1);
     194                  end if;
     195              dr_reg dreg(in1) = 0;  $ not in here any more.
     196              quit while;
     197              end if;
     198
     199          $   if operation is commutative, can check for same thing
     200          $   on second input.
     201          if  eb_comm ebtab(op) then  $ it is commutative.
     202              if  i2ldr & i2mode=am_reg & rl_perm reglis(i2mreg)=no then
     203                  omreg = i2mreg;  $ set output register.
dsc   17                  omode = am_reg;
     204              $   must store if live.
dsc   18                  if  rl_type reglis(i2mreg)=rt_live & isvar(in2) then
dsc   19                      store(i2mreg, in2);
dsc   20                      end if;
     208                  dr_reg dreg(in2) = 0;  $ not in here any more.
     209                  $   swap fields.
     210                  t = i1moff; i1moff = i2moff; i2moff = t;
     211                  t = i1mode; i1mode = i2mode; i2mode = t;
     212                  t = i1mreg; i1mreg = i2mreg; i2mreg = t;
     213                  t = in1; in1 = in2; in2 = t;
     214                  quit while;
     215                  end if;
     216              end if;
     217
     218          $   otherwise, hold the input register (just to be sure)
     219          $   and see if output register is available.
     220          rl_hold reglis(i1mreg) = yes;
     221          rl_hold reglis(i2mreg) = yes;
     222          getreg(omreg, i);  $ try to get a register.
     223          $   if got one, can exit loop.
dsc   21          if  omreg  then
dsc   22              omode = am_reg;
dsc   23              quit while;
dsc   24              end if;
     225
     226          $   at this point there are no registers available.  in this
     227          $   case, fake as if the inputs had last use and loop again.
     228          i = rt_live;  $ set next time to try all.
     229
     230          $   if a register does not have live status, show that
     231          $   it can be used.
     232          i1ldr = (rl_type reglis(i1mreg) ^= rt_live);
     233          i2ldr = (rl_type reglis(i2mreg) ^= rt_live);
     234          end while;
     235
     236      $   next, must get an input (for non-commutative -- first input)
     237      $   into the output register.
     238      until  yes;  $ quit when in register.
     239          if  (i1mreg = omreg) quit until;  $ have it.
     240
     241          if  i2mreg = omreg then   $ second arg. is in output register.
     242              if  eb_comm ebtab(op) = no then  $ not commutative op.
     243                  $   must check the operation.  if this is a
     244                  $   subtraction, complement input, set operation to
     245                  $   addition, and swap.  otherwise error.
     246                  if  op = ao_isu - (ao_fbo-1) then  $ normal sub.
     247                      emop(mo_ico, omreg, am_reg, omreg, 0); $ complemen
     248                      op = ao_iad - (ao_fbo-1);  $ set for add.
     249                  elseif  op = ao_rsu - (ao_fbo-1)  then $ if real.
     250                      emop(mo_rco, omreg, am_reg, omreg, 0); $ complemen
     251                      op = ao_rsu - (ao_fbo-1);  $ set for add.
     252                  else    $ error.
     253                      call aermey(19);  $ this is fatal error.
     254                      end if;
     255                  end if;
     256
     257              i2mreg = i1mreg; i2moff = i1moff; i2mode = i1mode;
     258              quit until;  $ have in register.
     259              end if;
     260
     261
     262          if  i1mode = am_reg then  $ this is in register.  copy it.
     263              mrcopy(omreg, i1mreg);  $ copy reg.
     264              quit until;  $ have in register.
     265              end if;
     266
     267          $   if operation is commutative, see if input 2 is in reg.
     268          if  i2mode = am_reg & eb_comm ebtab(op) then  $ ok.
     269              mrcopy(omreg, i2mreg);  $ move into reg.
     270              i2mreg = i1mreg; i2mode = i1mode; i2moff = i1moff; $ swap.
     271              quit until;
     272              end if;
     273
     274          $   otherwise, do load into output.
     275          $   if this is commutative operation with the first
     276          $   operand a short constant, swap operands.
     277          if  eb_comm ebtab(op) & isscon(in1) then  $ it is.
     278              i2moff=i1moff; i2mreg=i1mreg; i2mode=i1mode; in1=in2;
     279              end if;
     280
     281          $   get first operand into register.
     282          getvar(in1, gd_inregnu, t, omreg, t);
     283          end until;
     284
     285      $   finally, do operation.
     286      emop(eb_mop ebtab(op), omreg, i2mode, i2mreg, i2moff);
     287
     288      go to ret;
     289
     290
     291 .+eab.  $ defer sign, isign code until after bootstrap
     292         $ and do off-line for bootstrap.
     293 /l(ek_sign)/   $ -sign- or -isign- function.
     294
     295      $   first, get first input into a register if it is not already.
     296      if  i1mode ^= am_reg then  $ it is not in a register.
     297          getvar(in1, grtype, i1mode, i1mreg, i1moff);
     298          end if;
     299
     300      $   get register to use for output.
     301      i = rt_need;  $ initially, just see if one available.
     302      while  omode ^= am_reg;  $ exit when register in -omreg-.
     303
     304          $   see if can use input register.
     305          if  i1ldr & i1mode=am_reg & rl_perm reglis(i1mreg)=no  then
     306              omreg = i1mreg;  $ set to proper register.
     307              dr_reg dreg(in1) = 0;  $ not in here any more.
     308              quit while;
     309              end if;
     310
     311          $   try to get an appropriate register.
     312          rl_hold reglis(i1mreg) = yes;  $ hold this input.
     313          rl_hold reglis(i2mreg) = no;  $ but release other one.
     314          getreg(omreg, i);  $ try to get a register.
     315          $   if a register was obtained, use it.
     316          if  (omreg) quit while;
     317
     318          $   otherwise, must reset to use input.
     319          i1ldr = (rl_type reglis(i1mreg) ^= rt_live);  $ fake last use.
     320          i = rt_live;  $ set to force a register.
     321          end while;
     322
     323      $   do operation.  first, get absolute value.
     324      rrop(eb_mop ebtab(op), omreg, i1mreg);  $ -lper- or -lpr-
     325
     326      $   get a label and emit branch to it if second operand is
     327      $   positive.
     328      labget(lab); ifpos_op(in2, lab);  $ branch on second operand.
     329
     330      $   if was not positive, then do complement.
     331      rrop(eb_xmop ebtab(op), omreg, omreg);  $ -lcer- or -lcr-.
     332
     333      $   define ending label and free it.
     334      labdef(lab, no);   labfree(lab);
     335
     336      go to ret;
     337 ..eab
     338
     339
     340 .+eab.   $ defer mul/div special casing
     341 /l(ek_mul)/    $ multiplication.
     342
     343
     344      $   the first thing to do is to see which, if any, of the input
     345      $   registers can be pre-empted.  then call the -getregpair-
     346      $   routine to get a register pair.
     347
     348      mreg1 = 0; mreg2 = 0;  $ initially none can.
     349      if  (i1ldr & i1mode = am_reg & rl_perm reglis(i1mreg) = no)
     350          mreg1 = i1mreg;  $ can use first register.
     351      if  (i2ldr & i2mode = am_reg & rl_perm reglis(i2mreg) = no)
     352          mreg2 = i2mreg;  $ can use second register.
     353
     354      getregpair(mreg, mreg1, mreg2);  $ get pair into -mreg-.
     355
     356      $   next, get an input into the second register of the pair.
     357      until  yes;  $ exit when gotten.
     358          if  (mreg+1 = i1mreg) quit until;  $ got 1st.
     359          if  mreg+1 = i2mreg then  $ got 2nd -- exchange.
     360              t = in2; in2 = in1; in1 = t;
     361              t = i2mreg;  i2mreg = i1mreg;  i1mreg = t;
     362              t = i2moff;  i2moff = i1moff;  i1moff = t;
     363              t = i2mode;  i2mode = i1mode;  i1mode = t;
     364              quit until;
     365              end if;
     366
     367          $   else must load into register.
     368          getvar(in1, gd_inregnu, t, mreg+1, t);  $ force to -mreg+1-.
     369          end until;
     370
     371      $   set -mreg1- to the register to contain the output.
     372      mreg1 = mreg+1;   $ set for common code.
     373
     374 /muldiv/   $ this code is common for multiplication and division.
     375      $   if the second operand is not in a register and this is not
     376      $   the last usage of that operand, then load it into a
     377      $   register if one if available.
     378      if  i2ldr = no & i2mode^=am_reg then  $ try to get a register.
     379          rl_hold reglis(mreg) = yes; rl_hold reglis(mreg+1) = yes;
     380          getreg(mreg2, rt_need);  $ see if one is available.
     381          if  mreg2 then  $ there is one available.
     382              i2mreg = mreg2;  $ show which register is in.
     383              getvar(in2, gd_intoreg, i2mode, i2mreg, i2moff);
     384              end if;
     385          end if;
     386
     387      $   do operation.
     388      if  i2mode^=am_reg then   $ do -rx- operation.
     389          rxop(eb_xmop ebtab(op), mreg, i2moff, r0, i2mreg);
     390      else    $ do -rr- operation.
     391          rrop(eb_mop ebtab(op), mreg, i2mreg);
     392          end if;
     393
     394      rl_hold reglis(mreg+1) = no;  $ this is unheld.
     395
     396      $   must see if either register in the pair was
     397      $   holding one of the inputs to the operation.  if so, must
     398      $   show that the input is no longer in that register.
     399      if  i1mreg = mreg ! i1mreg = mreg+1 then  $ hit input one.
     400          dr_reg dreg(in1) = 0;   $ show not assigned.
     401          end if;
     402
     403      if  i2mreg = mreg ! i2mreg = mreg+1 then  $ hit input two.
     404          dr_reg dreg(in2) = 0;  $ show not assigned.
     405          end if;
     406
     407      $   must move the result to the output.  if the output
     408      $   is a permanently assigned register or if the register pair
     409      $   allocated is non-standard, must move the data.  otherwise,
     410      $   can just indicate that it resides in the pair.
     411      if  mreg1 = r1 ! mreg1 >= r14 then  $ bad place.
     412          reglis(r1) = 0; rl_type reglis(r1) = rt_permresv;  $ reset.
     413          if  omode^=am_reg then  $ must get output register.
     414              getreg(omreg, rt_live);  $ get one.
     415              end if;
     416
     417          $   just move to output.
     418          mcropy(omreg, mreg1);
     419          go to ret;  $ done.
     420          end if;
     421
     422      $   check if the output is a permanently assigned register.
     423      if  omode = am_reg then  $ it is a register.
     424          mrcopy(omreg, mreg1);  $ copy reg.
     425          reglis(mreg1) = 0;  $ clear register.
     426          go to ret;
     427          end if;
     428
     429      $   otherwise, can assign to output.
     430      omreg = mreg1;  $ show output is here.
     431      $   the regster which does not contain the output is
     432      $   to be concidered dead.
     433      if  omreg = mreg
     434          then    reglis(mreg+1) = 0;
     435          else    reglis(mreg) = 0;  end if;
     436
     437      go to ret;
     438
     439 /l(ek_div)/   $ division or -mod- function.
     440
     441      $   in this case, must see if can pre-empt the first input
     442      $   register and, if so, so indicate.  then a register pair is
     443      $   obtained.
     444      mreg1 = 0;  $ assume cannot pre-empt.
     445      if  (i1ldr & i1mode = am_reg & rl_perm reglis(i1mreg) = no)
     446          mreg1 = i1mreg;  $ can use.
     447
     448      $   [ds 11 apr  should issue aop for t10, and hence no need
     449      $   for reg pair here.]
     450      getregpair(mreg, mreg1, 0);  $ get register pair.
     451
     452      $   must load first input into high register of pair. note
     453      $   that do not bother to check for the case where this is not
     454      $   last use of the input because division is not that common
     455      $   an operation.
     456      if  mreg ^= i1mreg then  $ must put it in.
     457          getvar(in1, gd_inregnu, t, mreg, t);  $ move it.
     458          end if;
     459
     460      $   do shift down to high register.
     461      rxop(mop_srda, mreg, ws, r0, r0);  $ propagate sign through high.
     462
     463      $   prepare to branch to common code to emit operation.
     464      $   set -mreg1- to that register that will contain the output
     465      $   of the operation.
     466      mreg1 = mreg+1;  $ assume division.
     467      if  (iop = ao_mod) mreg1 = mreg;  $ set for -mod- function.
     468      go to muldiv;   $ enter common code.
     469
     470 ..eab
     471
     472
     473 /ret/   $ common return point.
     474      $   first, update status of output register.
     475      dr_reg dreg(out) = omreg;  $ show in this register.
     476      rl_subtype reglis(omreg) = rt_live;  $ show changed.
     477      rl_content reglis(omreg) = out;  $ show owner.
     478
     479 /noupdate/   $ branch here to skip status update.
     480      $   drop inputs.
     481      drop(iin1);  drop(iin2);  drop(iout);
     482
     483      return;
     484
     485 .+eab    macdrop(ek_norm)   macdrop(ek_mul)
     486 .+eab    macdrop(ek_div)    macdrop(ek_sign)
     487      macdrop(ek_shift)  macdrop(eb_mop)
     488      macdrop(eb_type)   macdrop(eb_comm)
     489      macdrop(eb_fp)
     490
     491      end subr emitbin;
       1 .=member emitcmp
       2      subr emitcmp(imask, iin1, iin2, lab);  $ emit comparison.
       3      $   this routine emits a compare and a branch.  it compares
       4      $   two inputs and will conditionally branch to a given label.
       5      size  imask(3);             $ conditional branch mask.
       6      size  iin1(ps);             $ first input.
       7      size  iin2(ps);             $ second input.
       8      size  lab(ps);              $ label to branch to.
       9      size  mask(ps);             $ copy of branch mask.
      10      size  in1(ps);              $ copy of first input.
      11      size  in2(ps);              $ copy of second input.
      12      size  i1ldr(1);             $ drop bit for first input.
      13      size  i2ldr(1);             $ drop bit for second input.
      14      size  i1mode(ps);            $ indirect bit for first input.
      15      size  i2mode(ps);            $ indirect bit for second input.
      16      size  i1mreg(ps);           $ machine register for first input.
      17      size  i2mreg(ps);           $ machine register for second input.
      18      size  i1moff(mosize);           $ machine offset for first input.
      19      size  i2moff(mosize);           $ machine offset for second input.
      20      size  mreg(ps);             $ register obtained.
      21      size  t(ps);                $ temporary.
      22      size  gtype(ps);       $ desired address type.
dsb   96      size  moctb(ps);  dims moctb(9);
dsb   97      +*  mo_cmptab(i) = moctb((i)+1) **  $ array is zero-origin
      24      data  mo_cmptab(bm_all)       = mo_jmp:
      25            mo_cmptab(bm_neg)       = mo_clt:
      26            mo_cmptab(bm_pos)       = mo_cgt:
      27            mo_cmptab(bm_zer)       = mo_ceq:
      28            mo_cmptab(binv(bm_all)) = mo_jmn:
      29            mo_cmptab(binv(bm_neg)) = mo_cge:
      30            mo_cmptab(binv(bm_pos)) = mo_cle:
      31            mo_cmptab(binv(bm_zer)) = mo_cne;
      32
      33      $   first, make copy of inputs and set some initial defaults.
      34      in1 = iin1; in2 = iin2; mask = imask;
      35      $   get last usage bits.
      36      i1ldr = lastdrop(in1);  $ get last usage counts.
      37
      38      i2ldr = lastdrop(in2);  $ get last usage counts.
      39
      40
      41      $   get machine descriptors for inputs.
      42      getdesc(in1, gd_use, i1mode, i1mreg, i1moff);
      43      getdesc(in2, gd_use, i2mode, i2mreg, i2moff);
      44
      45      $   see if this is not the last use of the first input and
      46      $   it is in storage.  load it into an available register if so.
      47      if  i1ldr = no & i1mode^=am_reg & isinif=no  then  $ can get to re
      48          getreg(mreg, rt_need);  $ see if reg available.
      49          if  mreg  then  $ if reg available.
      50              i1mreg = mreg;  $ copy to result register.
      51              getvar(in1, gd_intoreg, i1mode, i1mreg, i1moff);
      52              $   must check for the cases where both inputs same.
      53              if  in2 = in1  then  $ update in2 status also
      54                  i2mreg = mreg;  i2mode = am_reg;  i2moff = 0;
      55                  end if;
      56              end if;
      57          end if;
      58      $   do the same for the second input.
      59
      60      if i2ldr = no & i2mode^=am_reg & isinif=no  then  $ can get in2.
      61          getreg(mreg, rt_need);  $ see if reg available.
      62          if  mreg  then  $ if reg. available.
      63              i2mreg = mreg;  $ set result reg.
      64              getvar(in2, gd_intoreg, i2mode, i2mreg, i2moff);
      65              end if;
      66          end if;
      67
      68      $   get one of the inputs into a register.
      69      until  yes;   $ quit when one is loaded.
      70          mreg = i1mreg;  $ assume first input in a register.
      71          if  (i1mode = am_reg) quit until;  $ quit if it is.
      72          if  i2mode = am_reg then  $ second input is in a register.
      73              $   copy descriptors.
      74              mreg=i2mreg; i2mreg=i1mreg; i2mode=i1mode; i2moff=i1moff;
      75              bmswap(mask, t);  $ reverse branch mask.
      76              quit until;  $ indicate in register.
      77              end if;
      78
      79          $   must get a register.
      80          getreg(mreg, rt_live);  $ get register.
      81
      82          $   if the first input is a short constant, then
      83          $   will want to load second into the register.
      84          if  isscon(in1) then  $ it is.
      85              in1 = in2;  $ set to this input.
      86              i2mode = i1mode; i2mreg = i1mreg; i2moff = i1moff;
      87              bmswap(mask, t);  $ reverse branch mask.
      88              end if;
      89
      90          gtype = gd_intoreg;  if (isinif)  gtype = gd_inregnu;
      91          getvar(in1, gtype, i1mode, mreg, i1moff);
      92          if  (isinif) reglis(mreg) = 0;  $ clear status of gotten regis
      93          end until;
      94
      95      $   do the comparison.
      96      emop(mo_cmptab(binv(mask)), mreg, i2mode, i2mreg, i2moff);
      97      goto_op(lab);
      98
      99      drop(iin1);   drop(iin2);  $ drop the inputs.
dsb   98      macdrop(mo_cmptab)
     100
     101      end subr emitcmp;
       1 .=member emitif
       2      subr emitif(iop, inr, label);   $ emit an -if- operation.
       3      $   this routine is called to proces conditional branch
       4      $   operations.  it decides whether to do the operation as
       5      $   a storage operation or to load it into a register and test
       6      $   it in the register.
       7      size  iop(ps);          $ branch mask to use.
       8      size  inr(ps);          $ dummy register to test.
       9      size  label(ps);        $ label to branch to if condition true.
      10      size  mreg(ps);         $ machine register for operand.
      11      size  moff(mosize);     $ machine address.
      12      size  mode(ps);         $ machine mode.
      13
      14
      15 .+trace.
      16      if  trace_a then  $ trace output wanted.
      17          tintl('ifop, mask', iop) tintl('in', inr)
      18          tintl('l', label) endl
      19          end if;
      20 ..trace
      21
      22      $   first set flag to indicate whether this is last use of
      23      $   operation.  this will be used later.
      24
      25
      26      $   get description of variable.
      27      getdesc(inr, gd_use, mode, mreg, moff);
      28      if  mode ^= am_reg  then  $ if not in register.
      29          getvar(inr, gd_reg, mode, mreg, moff);  $ bring to reg.
      30          if  isinif  then   $ if in if.
      31              reglis(mreg) = 0;  dr_reg dreg(inr) = 0;
      32              end if;
      33          end if;
      34
      35      $   finally, emit branch instruction.
      36      branchop(iop, mreg, label);
      37
      38 /ret/    $   common return code.
      39
      40      drop(inr);  $ free if last use.
      41      end subr emitif;
      42      subr emitlong(op, outr, inr, length);  $ emit long op.
       1 .=member emitlon
       2      $   the routine emits code for the storage-storage operations.
       3      $   it uses a table to determine which machine operation to
       4      $   issue.  in addition, it handles the storing and freeing of
       5      $   words near the operand locations.
       6      size  op(ps);       $ internal operati!n code.
       7      size  outr(ps);     $ output dummy register.
       8      size  inr(ps);      $ input dummy register.
       9      size  length(ps);   $ length, in words, of operation to perform.
      10      size  imode(ps);    $ input address mode.
      11      size  omode(ps);    $ output address mode.
      12      size  imreg(ps);    $ machine register for input.
      13      size  imoff(mosize);    $ machine offset for input.
      14      size  omreg(ps);    $ machine register for output.
      15      size  omoff(mosize);    $ machine offset for output.
      16      size  mreg(ps);     $ machine register.
      17      size  i(ps), j(ps), k(ps);  $ temporaries.
      18      size  dw(ps);       $ pointer to dummy word.
      19
      20 .+trace.  $ generate trace code.
      21      if  trace_a then   $ if tracing these ops.
      22          tintl('longop, op', op) tintl('out', outr)
      23          tintl('in', inr) tintl('l', length) endl
      24          end if;
      25 ..trace
      26      $   must store any live forms of the input that fall
      27      $   into the range to be moved.
      28      if  op = ao_mvw then  $ only store if move operation.
      29          i = dw_word dword(dr_word dreg(inr)); j = i+length-1;
      30          dw = di_lword ditem(dr_item dreg(inr));   $ point to first wor
      31          while  dw;  $ while more in chain.
      32              $   see if in specified range.
      33              if  dw_word dword(dw) >= i & dw_word dword(dw) <= j then
      34                  $   it is.  see if primary register is live.
      35                  if  dr_reg dreg(dw_freg dword(dw)) then  $ there is on
      36                      if  rl_subtype reglis(dr_reg dreg(dw_freg
      37                          dword(dw))) = rt_live then    $ it is live.
      38                          store(dr_reg dreg(dw_freg dword(dw)),   $ stor
      39                              dw_freg dword(dw));  $ primary form.
      40                          end if;
      41                      end if;
      42                  end if;
      43
      44              dw = dw_next dword(dw);   $ get next in chain.
      45              end while;
      46          end if;
      47
      48      $   get descriptors for output and input and go do operation.
      49      getdesc(inr, gd_addr, imode, imreg, imoff);  $ get input.
      50      getdesc(outr, gd_addr, omode, omreg, omoff);  $ get output.
      51
      52      $   now emit the long operation.  first move the output address in
      53      $   to a register.
      54      $   if the start of the output is at offset zero from a register,
      55      $   then can use that register.
      56      if  omoff = 0 & omode = am_rel then  $ can use register.
      57          mreg = omreg;  $ set register to use.
      58      else  $ must get a register.
      59          getreg(mreg, rt_live);  $ get a register.
      60          emop(mo_lda, mreg, omode, omreg, omoff);  $ load address.
      61          reglis(mreg) = 0;  $ nothing usefull in register.
      62          end if;
      63
      64      $   now actually emit the move or clear.
      65      if  op = ao_mvw then  $ emit move.
      66          emopparm1 = length;  $ set length to move.
      67          emop(mo_mvw, mreg, imode, imreg, imoff);  $ emit the move.
      68      else  $ this must be a clear.
      69          imoff = 0;  mbo_blk imoff = bl_imm;  $ set for immediate.
      70          mbo_off imoff = length;  $ put length out as ea.
      71          emop(mo_zeb, mreg, am_mem, sparereg, imoff);  $ clear storage.
      72          end if;
      73
      74      $   must drop any output words that are in range modified.
      75      i = dw_word dword(dr_word dreg(outr));j = i+length-1;
      76      dw = di_lword ditem(dr_item dreg(outr));  $ get first word.
      77      while  dw;  $ loop until end of chain.
      78          $   see if in range.
      79          if  dw_word dword(dw) >= i & dw_word dword(dw) <= j then
      80              $   it is.  drop all assigned registers.
      81              k = dw_freg dword(dw);  $ point to first.
      82              if  dr_reg dreg(k) then  $ must free this one.
      83                  if  rl_perm reglis(dr_reg dreg(k))  then
      84                      omreg = dr_reg dreg(k);  $ get reg number
      85                      dr_reg dreg(k) = 0;  $ temporarily free.
      86                      getvar(k, gd_intoreg, omode, omreg, omoff);
      87                      rl_perm reglis(omreg) = yes;  $ show perm
      88                  else  $ not permanent, actually free.
      89                      reglis(dr_reg dreg(k)) = 0; $ free reg.
      90                      dr_reg dreg(k) = 0;  $ show not in reg.
      91                      end if;
      92                  end if;
      93              end if;
      94
      95          dw = dw_next dword(dw);  $ get next word.
      96          end while;
      97
      98      $   drop input and output.
      99      drop(outr);  $ drop output.
     100      if  op = ao_mvw then   drop(inr);  end if;  $ drop input.
     101
     102      end subr emitlong;
       1 .=member emitsub
       2      subr emitsub;   $ emit subroutine/function call.
       3      $   this routine emits the operations needed to call a subroutine
       4      $   or function.  the routine name is located and any needed
       5      $   housekeeping is done.  then the parameter list is generated.
       6      size  reg(ps);          $ dummy register.
       7      size  i(ps), j(ws), k(ps);  $ temporaries.
       8      size  hcode(ws/2);      $ hash code for base block.
       9      size  mreg(ps);         $ machine register.
      10      size  moff(mosize);         $ machine offset.
      11      size  mop(ps);          $ machine operation.
      12      size  mode(ps);         $ address mode.
      13      size  t(ws);            $ temporary if address goes negative.
vaxa 250      size  moff1(mosize);     $ temporary machine offset.
dsu  107 .+t32h  size  moff2(mosize);
      14
      15 .+trace.     $ handle special trace actions.
      16      if  trace_any then  $ if tracing.
      17          textl(' * call ') textl(dopsname)
      18          if  trace_a then  tintl(' np', dopnx)  end if;
      19          endl
      20          end if;
      21
      22      $   see if this 'routine' to be called is actually a
      23      $   special flag to turn on traces.
      24      if  .ch. 3, dopsname = 1r= then  $ it is special.
      25          if  .ch. 1, dopsname = 1rt & .ch. 2, dopsname = 1rr then
      26              dopsname = .s. 4, .len. dopsname-3, dopsname;
      27              $   set new trace values.
      28              trace_d = ('d' .in. dopsname) > 0;
      29              trace_o = ('o' .in. dopsname) > 0;
      30              trace_a = ('a' .in. dopsname) > 0;
      31              trace_r = ('r' .in. dopsname) > 0;
      32              trace_c = ('c' .in. dopsname) > 0;
      33              trace_l = ('l' .in. dopsname) > 0;
      34              trace_v = ('v' .in. dopsname) > 0;
      35
      36              trace_any = trace_d!trace_o!trace_a!trace_r!trace_c!
      37                  trace_l!trace_v;  $ set any trace info.
      38
      39              return;  $ end of dummy call.
      40              end if;
      41          end if;
      42 ..trace
      43
      44      $   if name longer than six characters, truncate to length six
      45      $   for possible output in generated code file.
vaxa 251 .+t10    if  (.len. dopsname > 6) .len. dopsname = 6;
      47
      48      $   must scan the contents of all permanently-assigned
dsk  309      $   registers.  if the register has live data in it and the
      50      $   data is a global variable, then it must be saved across
      51      $   the call because the called routine may modify it.
      52      $   the -hold- flag is set to those those registers that
      53      $   contain such global information so that they can be
      54      $   reloaded at the completion of the call.
      55
      56      $   this is only done when the -calldropgl- flag is set.
dsk  310      do  i = rlo to rhi;  $ search all registers.
rka   10          if  (rl_subtype reglis(i) ^= rt_need &
rka   11          rl_subtype reglis(i) ^= rt_live) cont do;
dsk  311          if  di_mblk ditem(dr_item dreg(rl_content reglis(i))) >=
dsk  312              bl_global  then $ this is a special case.
dsk  313              if  calldropgl  then  $ go ahead.
dsk  314                  if  rl_subtype reglis(i) = rt_live  then
dsk  315                      store(i, rl_content reglis(i))
dsk  316                      end if;
dsk  317
dsk  318                  if  rl_perm reglis(i)  then  $ if permanent.
dsk  319                      rl_hold reglis(i) = yes;  $ show special.
dsk  320                  else  $ not permanent.
dsk  321                      dr_reg dreg(rl_content reglis(i)) = 0; $ show not.
dsk  322                      reglis(i) = 0;  $ free register.
dsk  323                      end if;
dsk  324
dsk  325              else    $ dont hold.
dsk  326                  rl_hold reglis(i) = no;  $ show not special.
dsk  327                  end if;
dsk  328          else    $ not a global.
dsk  329              rl_hold reglis(i) = no;  $ show not special.
dsk  330              end if;
dsk  331          end do;
      74
      75      $   process arguments to calls, if any.
dsk  332      hcode = 0;
      76      if  dopnx then  $ arguments exist.
      77
      78          $   make a pass over the arguments to build the parameter
      79          $   list.  in addition, if any arguments are live in registers
      80          $   those registers must be stored.  also, if the item is
      81          $   in a permanent register, it must be flagged to be reloaded
      82          $   after the call is complete.
      84          do  i = 1 to dopnx;  $ scan all parameters.
      85              reg = dopxr(i);  $ get parameter -dreg- value.
      86              countup(pdlistp, pdlistdim, 'pdlist');  $ get space.
      87              pdlist(pdlistp) = 0;  $ clear parameter list entry.
      88
      89              $   if this parametet does not have a fixed address,
      90              $   will have to move it into the parm. list at run-time.
      91              $   in this pass over the parameters it is ignored
      92              $   because only known addresses are compiled into the
      93              $   parameter list.
      94              if  di_addrreg ditem(dr_item dreg(reg)) = 0 &
      95                  isind(reg) = no then  $ normal address.
      96                  $   can put this address into the parm list.
      97                  $   check for the case where an address has not been
      98                  $   assigned and assign an address to it.
      99                  if  di_mblk ditem(dr_item dreg(reg)) = 0 then
     100                      getdesc(reg, gd_addr, j, mreg, moff);  $ get value
     101                      rl_hold reglis(mreg) = no;  $ release.
     102                      end if;
     103
     104                  pd_block pdlist(pdlistp) =   $ set machine block.
     105                      di_mblk ditem(dr_item dreg(reg));
     106                  pd_madr  pdlist(pdlistp) =    $ machine address.
     107                      dw_madr dword(dr_word dreg(reg));
     108                  hcode = hcode .ex.    $ hash in machine address.
     109                      dw_madr dword(dr_word dreg(reg));
     110                  end if;
     111
     112              $   check for the case where the parameter is in a
     113              $   register.
     114              if  dr_reg dreg(reg).ne. 0 & isscon(reg)=no  then  $ it is
     115                  $   if live, must store.
     116                  if  rl_subtype reglis(dr_reg dreg(reg)) = rt_live then
     117                      store(dr_reg dreg(reg), reg);  $ do the store.
     118                      end if;
     119
     120                  $   if -callnodrop- is set, this is end of
     121                  $   processing for this variable.
     122                  if  (callnodrop) cont do;
     123
     124                  $   see how to drop.
     125                  if  rl_perm reglis(dr_reg dreg(reg)) then  $ perm.
     126                      rl_hold reglis(dr_reg dreg(reg)) = isvar(reg);
     127                  else    $ must do normal clear if variable.
     128                      if  isvar(reg) then  $ do normal clear.
     129                          clear(reg);  $ clear all fields.
     130                          end if;
     131                      end if;
     132                  end if;
     133              end do;
vaxa 252 .+t32    end if;
     134
     135
     136          $ allocate space in base block for the parameter list.
     137      $   if base block address would go negative, increment it.
     138      if (baselastaddr=1)  baselastaddr=2;
     139          baseprobe(j, hcode, dopnx, bt_plist,   $ get space for p-list.
     140              pdlistp - (dopnx-1), ar_plist, pdlistp);
     141          moff = 0;
vaxa 253 .+t10    t = bb_addr baseblock(j) - 2;
vaxa 254 .+t32    t = bb_addr baseblock(j) - 1;
     143          if  (t<0)  t = mneg(iabs(t));
     144          mbo_off moff = t;  $ set offset.
     145          mbo_blk moff = bl_base;
vaxa 255
vaxa 256
vaxa 257 .+t32    if  dopnx then  $ if parameters.
     146
     147          $   make a pass over the parameters to move any needed
     148          $   values into the parameter list at run-time.
     149          do  i = 1 to dopnx;  $ loop over all parameters.
     150              reg = dopxr(i);   $ get -dreg- number.
     151              if  di_addrreg ditem(dr_item dreg(reg)) then  $ else live.
     152                  $   see if last word is in register.  else must
     153                  $   get last word into a register.
     154                  if  (dw_word dword(dr_word dreg(reg))^=nwords(reg))
     155                      call aermey(20);   $ this is a fatal error.
     156                  if  dw_madr dword(dr_word dreg(reg)) = 1 then  $ last.
vaxa 258                      moff1 = moff;  mbo_off moff1 = mbo_off moff1 + i;
     157                      emop(mo_stw, di_addrreg ditem(dr_item dreg(reg)),
vaxa 259                        am_mem, sparereg, moff1);
     159                  else    $ use as temporary.
     160                      j = dw_madr dword(dr_word dreg(reg))-1;
     161                      if  (j<0)  j = mneg(-j);
vaxa 260                      moff1 = 0; mbo_off moff1 = j;
vaxa 261                      emop(mo_lda, sparereg, am_rel,
vaxa 262                          di_addrreg ditem(dr_item dreg(reg)), moff1);
vaxa 263                      moff1 = moff;  mbo_off moff1 = mbo_off moff1 + i;
     164                      emop(mo_stw, sparereg, am_mem,
vaxa 264                        sparereg, moff1);
     166                      end if;
     167              elseif  isind(reg) then   $ move in address.
vaxa 265 .+t10            emop(mo_ldw, sparereg, am_rel, parmreg,
vaxa 266 .+t10                di_anum ditem(dr_item dreg(reg)) - 1);
vaxa 267 .+t32            moff1 = 0;  mbo_off moff1 =
vaxa 268 .+t32                di_anum ditem(dr_item dreg(reg));
vaxa 269 .+t32            emop(mo_ldw, sparereg, am_rel, parmreg, moff1);
vaxa 270                  moff1 = moff;  mbo_off moff1 = mbo_off moff1 + i;
vaxa 271                  emop(mo_stw, sparereg, am_mem, sparereg, moff1);
dsu  108 .+t32h.
dsu  109              elseif nsheap_this &
dsu  110                (nsheap_blk = di_mblk ditem(dr_item dreg(reg))) then
dsu  111                  .s. 9, 3, ocs = 'sha';
dsu  112                  put ocsfile ,column(17);
dsu  113                  getdesc(reg, gd_addr, j, mreg, moff2);
dsu  114                  call emitea(am_mem, sparereg, moff2);
dsu  115                  put ocsfile ,',';
dsu  116                  moff1 = moff;
dsu  117                  mbo_off moff1 = mbo_off moff1 + i;
dsu  118                  call emitea(am_mem, sparereg, moff1); $ emit base blk
dsu  119                  call ocsput(0,0);
dsu  120 ..t32h
     171                  end if;
     172              kill(reg);  $ last usage of parameter.
     173              end do;
     174
     175          $   load parameter list address into r1.
     176 $        emop(mo_lda, r1, am_mem, sparereg, moff+1);
     177          end if;
     178
     179      $   emit call.
vaxa 272 .+t10    if  (.len. dopsname > 6) .len. dopsname = 6;
vaxa 273 .+t32    if  (.len. dopsname > 15) .len. dopsname = 15;
     181      .s. 9, 3, ocs = 'cal';
     182      put ocsfile ,column(17)
     183          :dopsname,a
     184          ,','  :dopnx,i  ,',' ;
     185      $   if arguments, put out ea of param list, else put zero.
vaxa 274 .+t10    if  dopnx then  $ if arguments.
vaxa 275 .+t10    call emitea(am_mem, sparereg, moff+1);
vaxa 276 .+t32    call emitea(am_mem, sparereg, moff);
vaxa 277 .+t10   else  put ocsfile ,'0'; end if;
     189      call ocsput(0, 0);  $ put code line.
     190
dst   77 .+enp.
dst   78      if enpopt  then $ if tracking active procs, indicate
dst   79        $ back in 'current' procedure.
dst   80          put ocsfile ,column(9) ,'enp' ,column(17)
dst   81            :currsubname,a ,',#' :(enpnum+enporg),i;
dst   82          call ocsput(0,0);
dst   83          end if;
dst   84 ..enp
     191      $   reload any permanent registers marked for reload.
     192      do  i = rlo to rhi;  $ search all registers.
     193          if  rl_perm reglis(i) & rl_hold reglis(i) then  $ got one.
     194              if  rl_type reglis(i) = rt_permlive !   $ check for data.
     195                  rl_type reglis(i) = rt_perm then  $ this is data.
     196               getdesc(rl_content reglis(i), gd_addr, mode, mreg, moff);
     197                  $   get operation to use for load.
     198                  emop(mo_ldw, i, mode, mreg, moff);
     199                  clear(rl_content reglis(i));  $ clear -dreg-.
     200                  rl_subtype reglis(i) = rt_need;  $ not live.
     201                  end if;
     202              end if;
     203          end do;
     204
     205
     206      callnodrop = no; calldropgl = no;  $ set default state of flags.
     207
     208      end subr emitsub;
       1 .=member emitsf
       2      subr emitsfld(op, inr, target);  $ emit field store operation.
       3      $   this routine emits code for field store operations.
       4      size  op(ps);            $ operation code.
       5      size  inr(ps);           $ input register to store.
       6      size  target(ps);        $ target register.
       7      size  mode(ps);          $ machine mode of target.
       8      size  mreg(ps);          $ machine register of target.
       9      size  moff(mosize);      $ machine offset of target.
      10      size  mreg1(ps);         $ machine register for input.
      11      size  mop(ps);           $ machine operation to emit.
      12
      13      $   get input to a register.
      14      getvar(inr, gd_reg, mode, mreg1, moff);
      15
      16      mreg = dr_reg dreg(target);
dsj   60      if  op = ao_spr  then  $ if spr.
      18          if  lastdrop(target)  then  $ if last use of target.
      19              if  mreg  then
      20                  if  rl_type reglis(mreg) = rt_need then
      21                      reglis(mreg) = 0;
      22                      dr_reg dreg(target) = 0;
      23                      mreg = 0;
      24                      end if;
      25                  end if;
      26              end if;
      27          if  (mreg)  rl_subtype reglis(mreg) = rt_live;
      28          end if;
      29
      30      $   now get ea for target.
      31      getdesc(target, gd_use, mode, mreg, moff);
      32
      33      $   now get machine operation to issue.  handle special case
      34      $   of halfword ops for spr.
      35      mop = mo_stf;  $ assume was stf_op.
      36      if  op = ao_spr then  $ it was not.
      37          mop = mo_spr;  $ set for normal case.
vaxa 278 .+t10.
      38          if  emopparm2 = mws/2 then  $ could be halfword.
      39              if  emopparm1 = 0 then  $ is right half.
      40                  mop = mo_str;  $ set to store right.
      41              elseif  emopparm1 = mws/2 then  $ is left half.
      42                  mop = mo_stl;  $ store left half.
      43                  end if;
      44              end if;
vaxa 279 ..t10
      45          end if;
      46
      47      $   now emit operation.
      48      emop(mop, mreg1, mode, mreg, moff);
      49
      50      drop(inr);  drop(target);  $ drop register.
      51
      52      end subr emitsfld;
       1 .=member emitun
       2      subr emitun(iop, outr, inr);  $ emit unary operation.
       3      $   this routine emits unary operations.  it is highly table-
       4      $   driven and handles special cases depending on mahchine
       5      $   register status.
       6      size  iop(ps);          $ internal operation code.
       7      size  outr(ps);         $ output operand.
       8      size  inr(ps);          $ input operand.
       9      size  imode(ps);      $ input one addressing mode
      10      size  imoff(mosize);  $ input addressing mode
      11      size  imreg(ps);        $ input machine register
      12      size  omreg(ps);        $ output machine register
      13      size  omode(ps);       $ output mode.
      14      size  omoff(mosize);       $ output offset.
      15      size  mop(ps);         $ machine operation.
      16      size  i(ps);               $ index.
      17
      18      size  eutab(ps);    $ table to drive routine.
      19      size  euotab(ps);  dims  euotab(ao_luo-ao_fuo+1);
      20      +*  eutab(i) = euotab(i-(ao_fuo-1))  **
      21      data
      22            eutab(ao_bfb) = mo_bfb:
      23            eutab(ao_bnb) = mo_bnb:
      24            eutab(ao_bno) = mo_bno:
      25            eutab(ao_iab) = mo_iab:
      26            eutab(ao_iao) = mo_iao:
      27            eutab(ao_ico) = mo_ico:
dsj   61            eutab(ao_ifr) = mo_ifr:
      28            eutab(ao_iso) = mo_iso:
      29            eutab(ao_rab) = mo_rab:
      30            eutab(ao_rco) = mo_rco:
dsj   62            eutab(ao_rfi) = mo_rfi:
dsj   63            eutab(ao_rtr) = mo_rtr:
      31            eutab(ao_ldf) = mo_ldf:
      32            eutab(ao_lpr) = mo_lpr;
      33
      34      macdrop(eutab)
      35
      36      size  mreg(ps);             $ machine register.
      37      size  ildr(1);              $ 'last usage of input'
      38      size  op(ps);               $ operation code within routine.
      39      size  t(ps);                $ dummy variable.
      40
      41 .+trace. $ generate trace info.
      42      if  trace_a then  $ this trace wanted.
      43          tintl('unop, op',iop) tintl('out',outr) tintl('in',inr) endl
      44          end if;
      45 ..trace
      46
      47      $   initialize for emission.
      48      op = iop - (ao_fuo-1);  $ get operation code for local use.
      49      i = gd_use;
      50      if  (isscon(inr) & dr_reg dreg(inr)=0)  i = gd_addr;
      51      getdesc(inr, i, imode, imreg, imoff);  $ get input.
      52      getdesc(outr, gd_use, omode, omreg, omoff);  $ get input into reg
      53
      54      $   get last usage value for variable.
      55      ildr = lastdrop(inr);  $ get last usage counts.
      56
      57      $   the next step is to see if the input is not in a register
      58      $   but this is not the last use.  in this case, bring into
      59      $   register, if one is available.
      60
      61      if  ildr = no & imode^=am_reg & isinif = no then  $ check for -i
      62          $   first, get a register of the appropriate type.
      63          getreg(mreg, rt_need);  $ get real or general.
      64
      65          if  mreg then  $ one is available.
      66              imreg = mreg;  $ show register that input will be in.
      67              getvar(inr, gd_intoreg, imode, imreg, imoff);  $ load.
      68
      69              if  outr = inr then  $ must update -out- status too.
      70                  omreg = mreg; omode = am_reg;
      71                  end if;
      72              end if;
      73          end if;
      74
      75      $   must get a register to use as the output of the
      76      $   operation.  this can come from either a register permanently
      77      $   assigned to the output, from the input if register status
      78      $   indicates such, or from a new register.  upon exit from
      79      $   the following 'maybe' loop, -omreg- contains the output
      80      $   register to use.
      81      until  yes;  $ get a register.
      82          if  (omode=am_reg) quit until;  $ if have it, quit.
      83          omreg = imreg;  $ see if safe to use input register.
      84          if  (imode=am_reg & ildr & rl_perm reglis(imreg)=no)
      85              quit until;
      86
      87          $   otherwise, get register if available.
      88
      89          $   see if must get a new register.
      90          i = rt_need;  $ assume dont have to.
      91          if  (rl_type reglis(imreg) > rt_need) i = rt_live;  $ do.
      92          if  (imode^=am_reg)  i = rt_live;  $ cannot use if not in reg.
      93          getreg(omreg, i);  $ get register for output.
      94          if  (omreg)  quit until;  $ if got one, exit.
      95          omreg = imreg;  $ else use input after all.
      96          end until;
      97
      98      $   see if input register used was input register.
      99      if  omreg = imreg then  $ it was.  must drop and/or store.
     100          if  rl_type reglis(imreg)=rt_live & isvar(inr)  then
     101              store(imreg, inr);
     102              end if;
     103          dr_reg dreg(inr) = 0;  $ show no longer in register.
     104          end if;
     105
     106      $   get machine operation and check for halfword case in lpr.
     107      mop = euotab(op);  $ get default operation.
vaxa 280 .+t10.
     108      if  mop = mo_lpr & emopparm2 = mws/2 then  $ could be special.
     109          if  emopparm1 = 0 then  $ is right half.
     110              mop = mo_ldr;  $ load right half.
     111          elseif  emopparm1 = mws/2 then  $ is left half.
     112              mop = mo_ldl;  $ load left half.
     113              end if;
     114          end if;
vaxa 281 ..t10
     115
     116      emop(mop, omreg, imode, imreg, imoff);  $ emit op.
     117
     118      $   set status of output register.
     119      rl_content reglis(omreg) = outr;  $ show it contains output.
     120      rl_subtype reglis(omreg) = rt_live;  $ show live.
     121      dr_reg dreg(outr) = omreg;  $ point -dreg- to -mreg-.
     122
     123      drop(inr); drop(outr);  $ drop operands.
     124
     125
     126      end subr emitun;
       1 .=member branchr
       2      subr branchr(bmask, mreg, label);  $ handle branches.
       3      $   process branch operations.
       4      size  bmask(4);     $ input branch mask.
       5      size  label(ps);    $ label number to branch to.
       6      size  fixptr(ps);   $ pointer to fixup table.
       7      size  mreg(ps);     $ machine register.
       8      size  labent(lablistsz);    $ temporary
       9      size  bops(.sds.3); dims bops(8);
      10      +*  bop(bm, op) = bops(bm+1) = op **
      11
      12      data
vaxa 282 .+t10    bop(bm_all       , 'jmp'):
vaxa 283 .+t32    bop(bm_all       , 'jma'):
      14      bop(bm_neg       , 'jlt'):
      15      bop(bm_pos       , 'jgt'):
      16      bop(bm_zer       , 'jeq'):
      17      bop(binv(bm_all) , 'jmn'):
      18      bop(binv(bm_neg) , 'jge'):
      19      bop(binv(bm_pos) , 'jle'):
      20      bop(binv(bm_zer) , 'jne');
      21      macdrop(bop)
      22
      23 .+trace.     $ generate trace code.
      24      if  trace_a then  $ print trace info.
      25          tintl('branchop, mask', bmask) tintl('label', label) endl
      26          end if;
      27 ..trace
      28
      29      put ocsfile ,column(9)
      30          :bops(bmask+1),a(3), column(17)
dss   52          ,'r' :mreg-1,i
dss   53          ,',l'
dss   54          :(label+lablorg),i(labcol, labcol);
      32      call ocsput(0, 0);
      33      end subr branchr;
       1 .=member getdesc
       2      subr getdescr(var, type, mode, reg, off);  $ get register descr.
       3      $   this routine is passed a dummy register pointer in
       4      $   variable -var- and a type in -type-.
       5      size  var(ps);       $ variable to process.
       6      size  type(ps);      $ type of call.
       7      size  mode(ps);        $ indirect reference flag.
       8      size  reg(ps);       $ machine register.
       9      size  off(mosize);       $ machine offset.
      10      size  hcode(mws);      $ hash code for temporary allocation.
      11      size  i(ps), j(ps);  $ temporary pointers.
      12      size  blk(ps), adr(ws);  $ block  and address.
      13
      14      $   first, unless the type is -gd_addr-, in which case a value
      15      $   in a register is not wanted, if a register contains the value,
      16      $   return it.
      17
      18      if  dr_reg dreg(var) then   $ check for special type.
      19          if  type ^= gd_addr then  $ return value in reg.
      20              reg = dr_reg dreg(var);  $ set register.
      21              mode = am_reg;  $ show not indirect.
      22              adr = 0;  blk = 0;
      23              go to ret;  $ return value.
      24              end if;
      25          end if;
      26
      27      $   if address of value is in register, use it as indirect.
      28      if  di_addrreg ditem(dr_item dreg(var)) then  $ have this case.
      29          reg = di_addrreg ditem(dr_item dreg(var));  $ set register.
      30          adr = (dw_madr dword(dr_word dreg(var)))-1;  $ set offset.
      31        blk = 0;
      32          mode = am_rel;  $ set to use indirectly.
      33          go to ret;
      34          end if;
      35
      36      $   handle case where variable is parameter to routine.
      37      if  isind(var) then  $ is an argument.
      38          if  (dr_word dreg(var) ^= di_lword ditem(dr_item dreg(var)))
      39              call aermey(23);   $ this is a fatal error.
      40          $   get a base register for the address.
vaxa 284 .+t10    adr = di_anum ditem(dr_item dreg(var))-1;  blk = 0;
vaxa 285 .+t32    adr = di_anum ditem(dr_item dreg(var));  blk = 0;
      42          reg = parmreg;  mode = am_reli;  blk = 0;
      43          go to ret;
      44          end if;
      45
      46      if  isscon(var) & type^=gd_addr  then  $ if short constant
      47          off = 0;  adr = conval(var);  blk = bl_imm;
      48          reg = sparereg;
      49          mode = am_mem;
      50          go to ret;
      51          end if;
      52
      53      $   if address has not been assigned, this must be a
      54      $   constant that resides in the base block.
      55      if  di_mblk ditem(dr_item dreg(var)) = 0 then  $ not assigned.
      56          if  (di_baseblk ditem(dr_item dreg(var)) = no ! ismw(var))
      57              call aermey(24);   $ this is a fatal error.
      58          i = di_chain ditem(dr_item dreg(var));   $ baseblock pointer.
      59          if  (bb_type baseblock(i) ^= bt_const) call aermey(24);
      60
      61          $   must allocate an address to the constant.
      62          bb_addr baseblock(i) = baselastaddr;  $ set address.
      63          di_mblk ditem(dr_item dreg(var)) = bl_base;  $ set block.
      64          dw_madr dword(dr_word dreg(var)) = baselastaddr;  $ address.
      65          baselastaddr = baselastaddr + 1;  $ step up adddess.
      66
      67          $   put entry on chain.
      68          if  baselast then  $ is not first.
      69              bb_chain baseblock(baselast) = i;  $ set onto chain.
      70          else    $ this is first entry.
      71              basefirst = i;  $ set to chain head.
      72              end if;
      73
      74          baselast = i;  $ show this is last in chain.
      75          end if;
      76
      77      mode = am_mem;  $ in memory.
      78      reg = sparereg;  $ constant pseudo-reg.
      79      blk = di_mblk ditem(dr_item dreg(var));
      80      adr = dw_madr dword(dr_word dreg(var)) - 1;
      81
      82 /ret/
      83      if  (adr<0)  adr = mneg(iabs(adr));
      84      off = 0;  mbo_blk off = blk;  mbo_off off = adr;
      85 .+trace.     $ compile trace code.
      86      if  trace_r then  $ if tracing machine registers
      87          tintl('getdesc var', var) tintl('type', type)
      88          textl(' --> ')  tintl('reg', reg)
      89          tintl('mode',mode) tintl('blk', blk)
      90          textl('off ')
      91          if  .f. mps, 1, adr  then  $ if negative offset
      92              textl('-') intl(mneg(adr))
      93          else
      94              intl(adr)
      95              end if;
      96          endl end if;
      97 ..trace
      98
      99      rl_hold reglis(reg) = yes;  $ indicate register needed soon.
     100      end subr getdescr;
     101      subr getvarr(var, type, mode, mreg, moff);  $ get variable.
       1 .=member getvar
       2      $   this routine is called to reference a dummy register.  it
       3      $   can be used to load a dummy register into a machine register,
       4      $   to get the address of a dummy register's variable, or to
       5      $   get a dummy register into any addressable mode.  the type is
       6      $   used to determine parameters to use to determine what
       7      $   operations to issue.  -mode-, -mreg-, and -moff- are set as
       8      $   in -getdescr-.
       9      size  var(ps);          $ dummy register.
      10      size  type(ps);         $ type of call.
      11      size  mode(ps);          $ indirect flag.
      12      size  mreg(ps);         $ machine register to return.
      13      size  moff(mosize);         $ machine offset.
      14      size  i(ps), j(ps);     $ temporaries.
      15      size  mreg1(ps);        $ temporary machine register.
      16      size  mode1(ps);        $ temporary machine indirect flag.
      17      size  moff1(mosize);        $ temporary machine offset.
      18      size  mop(ps);          $ machine operation to issue.
      19
      20      $   table for actions depending on type.
      21      size  gvtab(2);         $ define table.
      22      dims  gvtab(num_gd);    $ number of types.
      23
      24      $   macros for bits in table.
      25      +*  gt_forcr = .f. 1, 1, **  $ force into any register.
      26      +*  gt_forci = .f. 2, 1, **  $ force into specific register.
      27
      28      +*  gvt(i, fr, fi) =   $ macro to define table.
      29          gvtab(i) = fi*2+fr **
      30
      31      data    $ initialize type table.
      32      $     type       fr   fi
      33      $     ----       --   --
      34      gvt(gd_addr,     no,  no):
      35      gvt(gd_use,      no,  no):
      36      gvt(gd_reg,     yes,  no):
      37      gvt(gd_intoreg, yes, yes):
      38      gvt(gd_inregnu, yes, yes);
      39
      40      macdrop(gvt)
      41
      42      $   first, get descriptor for variable.
      43      getdesc(var, type, mode1, mreg1, moff1);
      44      mode = mode1;  moff = moff1;  $ set user return values.
      45
      46      $   see if the variable is in a register.
      47      if  mode1 = am_reg then  $ it is in a register.
      48          $   if must force into a
      49          $   specific register.
      50          if  gt_forci gvtab(type)  then
      51
      52              $   if in the desired register, return.
      53              if  (mreg1 = mreg) return;
      54
      55              mrcopy(mreg, mreg1);  $ copy reg.
      56
      57              $   unless type is not to update status, do the
      58              $   status update.
      59              if  type ^= gd_inregnu then  $ must do update.
      60                  $   if old was permanent, build new form.
      61                  if  rl_perm reglis(mreg1) then  $ it is.
      62$                     call gfdreg(mreg, var);  $ get new -dreg-.
      63                      call aermey(34);
      64                  else    $   can do simple update.
      65                      reglis(mreg) = reglis(mreg1);  $ copy status.
      66                      reglis(mreg1) = 0;  $ clear old status.
      67                      dr_reg dreg(var) = mreg;  $ show in register.
      68                      end if;
      69                  end if;
      70
      71          else    $ it is ok as is.
      72              mreg = mreg1;  $ copy register given.
      73              end if;
      74
      75
      76      else    $   dummy register is not in a machine register.
      77          $   see if must load to a register.
      78          if  gt_forcr gvtab(type) then  $ must get into register.
      79              mode = am_reg;  $ show will be in register.
      80
      81              $   unless are going to force into a particular
      82              $   register, must get a register.
      83              if  gt_forci gvtab(type) = no then  $ must get a register.
      84                  getreg(mreg, rt_live);  $ get register.
      85                  end if;
      86
      87              $   if the output register is not real and the input
      88              $   is a short constant, can bring it in without a
      89              $   storage reference.
      90              if  isscon(var) & conval(var)=0  then
      91                  mrclear(mreg);  $ zeroize reg.
      92
      93              else    $ not constant.
      94                  emop(mo_ldw, mreg, mode1, mreg1, moff1);
      95                  end if;
      96
      97              $   unless this was a no-update call, update status.
      98              if  type ^= gd_inregnu then  $ must update.
      99                  rl_content reglis(mreg) = var;  $ show owner.
     100                  dr_reg dreg(var) = mreg;  $ show which register.
     101                  rl_type reglis(mreg) = rt_need;  $ reduce type.
     102                  end if;
     103
     104          else    $ it is ok as is.
     105              mreg = mreg1;  $ copy register given.
     106              end if;
     107          end if;
     108
     109 .+trace.     $   emit trace code.
     110      if  trace_r then  $ print trace info.
     111          tintl('getvar', var) tintl('mreg', mreg) endl
     112          end if;
     113 ..trace
     114
     115      rl_hold reglis(mreg) = yes;  $ hold gotten register.
     116
     117      end subr getvarr;
       1 .=member getreg
       2      subr getregr(type);  $ get a register.
       3      $   thus routine is the register allocator for the general
       4      $   purpose registers.  it returns the register number via the
       5      $   global variable -gotreg-.
       6      size  type(ps);         $ register type.
       7      size  lo(ps), hi(ps);   $ search limits.
       8      size  i(ps);            $ loop variable.
       9      size  blru(ps);         $ best lru value so far.
      10      size  btype(ps);        $ best type so far.
      11      size  reg(ps);          $ dummy register pointer.
      12
      13      $   select the register bounds to search.
      14      lo = nextgfree; hi = rhi;  $ set high bounds for general.
      15
      16      gotreg = 0;  $ initially dont have a register.
      17      blru = 4b'1000';  $ set to worst lru value.
      18      btype = type;  $ set to worst allowable type.
      19      if  (btype = rt_live) btype = rt_liveaddr;  $ ensure -live- gets.
      20
      21      $   scan for best register to use.
vaxa 286 .+t10    do  i = nextgfree to rhi;   $ scan all registers.
vaxa 287 .+t32    do  i = rlo to nextgfree;   $ scan all registers.
      23          if  (rl_hold reglis(i)) cont do;  $ skip if held.
      24          if  (rl_addrhold reglis(i)) cont do;  $ skip if held.
      25          if  (rl_type reglis(i) > btype) cont do;  $ worse type.
      26          if  (rl_type reglis(i) = btype & rl_usevalue reglis(i) > blru)
      27              cont do;  $ worse lru for same type.
      28
      29          $   else, this is best so far.
      30          gotreg = i;  $ set to use this register.
      31          btype = rl_type reglis(i);  $ set best type so far.
      32          blru = rl_usevalue reglis(i);  $ set best lru value so far.
      33          end do;
      34
      35
      36      if  gotreg then  $ found a register.
      37          $   select method of dropping this register by its prior type.
      38          go to dtyp(btype) in rt_dead to rt_liveaddr;
      39
      40 /dtyp(rt_live)/    $ drop live register.
      41          store(gotreg, rl_content reglis(gotreg));  $ store it.
      42          $   status is -need- so fall through.
      43
      44 /dtyp(rt_need)/  $ value in register.
      45          dr_reg dreg(rl_content reglis(gotreg)) = 0;  $ not in reg.
      46          go to dtyp(rt_dead);  $ register is dead.
      47
      48 /dtyp(rt_address)/   $ address is in register.
      49          di_addrreg ditem(rl_content reglis(gotreg)) = 0;
      50          go to dtyp(rt_dead);  $ type is dead.
      51
      52 /dtyp(rt_liveaddr)/   $ live address in register.
      53          store(gotreg, dw_freg dword(di_lword ditem(rl_content
      54              reglis(gotreg))));  $ store into primary register.
      55          $   status is -dead- so fall through.
      56
      57 /dtyp(rt_dead)/  $ register can be used.
      58          reglis(gotreg) = 0;  $ clear register status.
      59          rl_type reglis(gotreg) = type;  $ set to desired type.
      60          rl_hold reglis(gotreg) = yes;  $ hold gotten register.
      61
      62
      63          end if;
      64
      65
      66 .+trace.
      67      if  trace_r then   $ print register info.
      68          tintl('gotreg', gotreg) tintl('type', type) endl
      69          end if;
      70 ..trace
      71
      72      end subr getregr;
       1 .=member getpair
       2 .+eab.
       3      subr getrpair(use1, use2);  $ get a register pair.
       4      $   this routine is called by the -getregpair- macro to get a
       5      $   pair of registers.  it first checks to see if a pair exists
       6      $   of which neither register is on hold.  the best such pair is
       7      $   picked and a pair containing one of the 'ok-to-use' registers
       8      $   is weigthed more heavily.  if no normal registers are a
       9      $   available, r0-r1 and r14-r15 are tried, in that order.
      10      $   the lowest register of the gotten pair is returned via
      11      $   global variable -gotrpair-.
      12      size  use1(ps), use2(ps);   $ registers that can be used.
      13      size  i(ps), j(ps);         $ temporaries.
      14      size  btype(ws);            $ best type so far.
      15      size  blru(ws);             $ best lru value so far.
      16      size  type(ws);             $ type of this pair.
      17      size  lru(ws);              $ lru value of this pair.
      18      size  reg(ps);              $ temporary register.
      19
      20      $   first, scan all registers to find the best available
      21      $   pair.  note that can use a register which has -addrhold-
      22      $   set as long as it does not also have -hold- set because
      23      $   it can be moved to another register.
      24      btype = rt_liveaddr*2;  $ set to worst type.
      25      blru = 4b'1000'*2;  $ set to worst lru.
      26      gotrpair = 0;  $ show didn't find any yet.
      27 $ rhi was r10, not r12 (check).
      28      do  i = rlo to rhi by 2;  $ scan all pairs.
      29          $   set combined values for both registers.
      30          type = 0; lru = 0;  $ set counters to zero.
      31          do  j = i to i+1;   $ scan both registers in pair.
      32              if  (rl_addrhold reglis(j))  cont do i;  $ if perm.
      33              if  (rl_perm reglis(j)) cont do i;  $ or if perm.
      34              if  j = use1 ! j = use2 then  $ can use this one.
      35                  type = type-1;  lru = lru-1;  $ make this seem better.
      36              else    $ just add types and lru value.
      37                  if  (rl_hold reglis(j)) cont do i;  $ skip if held.
      38                  type = type+rl_type reglis(j);  $ add type.
      39                  lru = lru+rl_usevalue reglis(j);  $ add lru.
      40                  end if;
      41              end do j;
      42
      43          $   that have the combined type and useage value of
      44          $   the pair, if this is worse than the best so far, skip.
      45          if  (type > btype) cont do;  $ worse type.
      46          if  (lru > blru) cont do;    $ worse lru value.
      47          gotrpair = i;  $ show register obtained.
      48          btype = type; blru = lru;  $ set new 'best' values.
      49          end do i;
      50
      51      $   see if got a register.
      52      if  gotrpair  = 0 then  $ didn't.. try r0 and r14.
      53              call aermey(25);
      54              end if;
      55  $ [ds 11 apr  what does end if below close...]
      56          end if;
      57
      58
      59      $   scan both registers and drop them as needed.
      60      do  j = gotrpair to gotrpair+1;  $ scan over both in pair.
      61          $   hold both registers.
      62          rl_hold reglis(gotrpair)=yes; rl_hold reglis(gotrpair+1)=yes;
      63          if  j ^= use1 & j ^= use2 & j ^= r1 then  $ must drop.
      64              go to drp(rl_type reglis(j)) in rt_dead to rt_liveaddr;
      65          else    $ cannot drop register.
      66              cont do;  $ go around loop again.
      67              end if;
      68
      69 /drp(rt_need)/    /drp(rt_address)/   /drp(rt_live)/
      70 /drp(rt_liveaddr)/   $ most needed types.
      71          $   in this case try to get a another register of the desired
      72          $   type and do a move.
      73          getreg(gotreg, rl_type reglis(j));  $ try to get one.
      74          if  gotreg then  $ got one.
      75          mrcopy(gotreg, j);  $ copy reg.
      76              reglis(gotreg) = reglis(j);  $ move status.
      77              rl_hold reglis(gotreg) = no;  $ but clear hold.
      78              end if;
      79
      80          $   if type is address update all forms or otherwise
      81          $   just one.
      82          if  rl_type reglis(j) = rt_address !   $ update all forms.
      83              rl_type reglis(j) = rt_liveaddr then  $ go ahead.
      84              di_addrreg ditem(rl_content reglis(j)) = gotreg;
      85          else    $  data -- just clear one form.
      86              dr_reg dreg(rl_content reglis(j)) = gotreg;  $ update.
      87              end if;
      88
      89 /drp(rt_dead)/    $ need not drop anything.
      90          reglis(j) = 0;  $ so just clear status.
      91          cont do;
      92
      93          end do j;
      94
      95      $   just clear to set final status.
      96      rl_hold reglis(gotrpair) = yes;  $ hold first register.
      97      rl_hold reglis(gotrpair+1) = yes;   $ hold second.
      98
      99 .+trace.
     100      if  trace_r then  $ print trace info.
     101          tintl('getregpair, reg', gotrpair) tintl('u1', use1)
     102          tintl('u2', use2) endl
     103          end if;
     104 ..trace
     105
     106      end subr getrpair;
     107 ..eab
       1 .=member storer
       2      subr storer(mreg, reg);  $ store a machine register.
       3      $   this routine is called to store the contents of a
       4      $   machine register in order to free the register.  it
       5      $   is called for two classes of contents.  in the case
       6      $   where the register is a live address, it is called to
       7      $   move the data pointed to by the register into a
       8      $   temporary.  in the other cases, the register contains
       9      $   data that is simply stored.  note that this routine
      10      $   may be called by the register allocator and this must
      11      $   be carefull which routines it calls.
      12      size  mreg(ps);     $ machine register to store.
      13      size  reg(ps);      $ dummy register to store into.
      14      size  mreg1(ps);    $ machine register for item.
      15      size  moff1(mosize);    $ machine offset for item.
      16      size  mode1(ps);     $ machine mode for item.
      17      size  t(ws);         $ temporary.
      18      size  i(ps);        $ loop variable.
      19
      20 .+trace.  $ print trace code if wanted.
      21      if  trace_r then  $ trace code is wanted.
      22          tintl('storer, mreg', mreg) tintl('reg', reg) endl
      23          end if;
      24 ..trace
      25
      26      $   check if this is the case of data in a register.
      27      if  rl_subtype reglis(mreg) ^= rt_liveaddr then  $ it is.
      28          $   must get the address of the item for which
      29          $   this register corresponds.  the only time that
      30          $   have trouble and cannot do this directly is when
      31          $   have a word other than the last of an argument.
      32          $   so first handle the simple case.
      33          if  isind(reg) = no ! dr_word dreg(reg) = $ test for simple.
      34              di_lword ditem(dr_item dreg(reg)) !
      35              di_addrreg ditem(dr_item dreg(reg)) then  $ it is.
      36              getdesc(reg, gd_addr, mode1, mreg1, moff1);  $ get item.
      37          else    $ this is the less simple case.  in this case,
      38              $   will get the address of the last word and then
      39              $   subtract enough to point to the desired position.
vaxa 288 .+t10        emop(mo_ldw, sparereg, am_reg, parmreg,
vaxa 289 .+t10            di_anum ditem(dr_item dreg(reg))-1);
vaxa 290 .+t32        moff1=0; mbo_off moff1=di_anum ditem(dr_item dreg(reg));
vaxa 291 .+t32        emop(mo_ldw, sparereg, am_reg, parmreg, moff1);
      42              mreg1 = sparereg;
      43              mode1 = am_rel;
      44          t = dw_madr dword(dr_word dreg(reg)) - 1;  $ get desired addre
      45          if  (t<0) t = mneg(iabs(t));  $ set to valid machine address.
      46          moff1 = 0;  mbo_off moff1 = t;  $ set offset.
      47              end if;
      48
      49          $   get operation to issue.
      50          $   do the actual store.
      51          emop(mo_stw, mreg, mode1, mreg1, moff1);
      52
      53          $   set the status of the register to only needed if it
      54          $   was live before.
      55          if  (rl_subtype reglis(mreg) = rt_live)   $ update.
      56              rl_subtype reglis(mreg) = rt_need;
      57
      58
      59
      60      else    $   this is a live address in a register.
      61          $   first check to see if this is a valid call.
      62          if  (rl_content reglis(mreg) ^= dr_item dreg(reg))
      63              call aermey(27);  $ this is an error.
      64
      65          if  (istemp(reg) = no ! ismw(reg) = no) call aermey(28);
      66
      67          $   get the word offset (-1) that the register is
      68          $   pointing to.
dsu  121          t = (dw_word dword(dr_word dreg(reg)) -
dsu  122                  dw_madr dword(dr_word dreg(reg))) * mcpw;
      71
      72          $   if it is not pointing to the first word, must
      73          $   adjust it so it does.
      74          if  t then  $ must adjust.
      75              if  (t<0) t = mneg(iabs(t));  $ set machine address.
      76              moff1 = 0;  mbo_blk moff1 = bl_imm;  $ show immediate.
      77              mbo_off moff1 = t;  $ set constant to subtract.
      78              emop(mo_isu, mreg, am_mem, sparereg, moff1);  $ do subtrac
      79              end if;
      80
      81          $   must get the address of the item back.
      82          $   first, do another validity check.
      83          if  (di_baseblk ditem(dr_item dreg(reg))) call aermey(28);
      84
      85          t = vv_madr voa(di_chain ditem(dr_item dreg(reg))) -
      86                  nwords(reg);  $ get low address -1.
      87
      88          $   update ditem status to show no longer floating
      89          $   address in register.
      90          di_addrreg ditem(dr_item dreg(reg)) = 0;  $ no register.
      91
      92          $   update the address fields in each word to reflect
      93          $   the core address.
      94          i = di_lword ditem(dr_item dreg(reg));  $ point to head.
      95          while  i;  $ while more words in chain.
      96              dw_madr dword(i) = t + dw_word dword(i);
      97              i = dw_next dword(i);  $ step to next.
      98              end while;
      99
     100          $   get address to store into and emit the move.
     101          moff1 = 0; mbo_blk moff1 = di_mblk ditem(dr_item dreg(reg));
     102          mbo_off moff1 = t;  $ set offset of start (left end) of item.
     103          emopparm1 = nwords(reg);  $ set length to move.
dsu  123          emop(mo_mvx, mreg, am_mem, sparereg, moff1);  $ move to storag
     105
     106          reglis(mreg) = 0;  $ show register is dead.
     107          end if;
     108
     109      end subr storer;
       1 .=member mover
       2      subr mover(outr, inr);  $ move from out -dreg- to another.
       3      $   this routine is called by the -move_op- macro to move
       4      $   data from one -dreg- to another.  it handles various
       5      $   cases depending on the lastuse status of the output and
       6      $   input and whether the output and input are already assigned
       7      $   to registers.
       8      size  outr(ps);     $ output dummy register.
       9      size  inr(ps);      $ input dummy register.
      10      size  omode(ps);      $ set if output is indirect (in core)
      11      size  imode(ps);      $ set if input is in core.
      12      size  ooff(mosize);     $ core offset of output if in core.
      13      size  ioff(mosize);     $ core offset of input.
      14      size  omreg(ps);    $ output register (or base if in core).
      15      size  imreg(ps);    $ input register.
      16      size  oldr(1);      $ set if last usage of output.
      17      size  ildr(1);      $ set if last usage of input.
      18      size  treg(ps);     $ temporary machine register.
      19      size  mop(ps);      $ machine operation to issue.
      20      size  t(ps);        $ temporary.
dsj   64      size  moff(mosize);     $ temporary.
      21
      22 .+trace.
      23      if  trace_a then  $ print trace code.
      24          tintl('move, out', outr) tintl('in', inr) endl
      25          end if;
      26 ..trace
      27
      28      if  (inr = outr) go to ret;  $ this is a no-op.
      29
      30      $   first, get information about the input.
      31      ildr = lastdrop(inr);
      32
      33      $   get location descriptor for input.
      34      getdesc(inr, gd_use, imode, imreg, ioff);
      35
      36      $   get info. for output.
      37      oldr = lastdrop(outr);
      38      getdesc(outr, gd_use, omode, omreg, ooff);  $ get locator.
      39
      40      $   check for the case where the output will be used again
      41      $   and is not assigned to a register and where the input is
      42      $   in a register and this is it's last use.  in this case,
      43      $   re-assign the register to the output.
      44      if  omode^=am_reg & oldr = no & ildr & imode=am_reg then  $ have t
      45          $   if the input register is permanently assigned, it cannot
      46          $   be re-assigned to the output.  so in that case, this
      47          $   proceedure will not be used.
      48          if  rl_perm reglis(imreg) = no then  $ ok to re-assign.
      49              if  rl_type reglis(imreg)=rt_live & isvar(inr)  then
      50                  store(imreg, inr);
      51                  end if;
      52              rl_content reglis(imreg) = outr;  $ set to output.
      53              rl_type reglis(imreg) = rt_live;  $ set to live.
      54              dr_reg dreg(inr) = 0;  $ set to null in this case.
      55              dr_reg dreg(outr) = imreg;  $ set output to old reg.
      56              go to ret;   $ done in this case.
      57              end if;
      58          end if;
      59
      60      if  oldr & isscon(inr) & conval(inr)=0  then  $ if zero.
      61          emop(mo_zew, r0, omode, omreg, ooff);  $ issue zew.
      62          go to ret;
      63          end if;
      64
      65      $   if input is in storage, then it must be loaded
      66      $   into a register.
      67      if  imode^=am_reg then   $ input is in storage.
      68          $   must determine whether this register will be
      69          $   to the input or the output because the register should
      70          $   be of the same mode as the value to which it is being
      71          $   assigned.  if this is the last usage of the input, then
      72          $   the register is assigned to the output and vice versa.
      73          if  ildr & omode=am_reg then  $ last use of input -- assign to
      74              $   if output is already assigned to a register, can use
      75              $   it.  (occurs when output is permanently in register).
      76              treg = omreg;  $ get output register.
      77          else    $   last usage of output -- assigned to input.
      78              $   note that need not check for output permanently in
      79              $   register because know that it is storage.
      80              getreg(treg, rt_live);  $ get register.
      81              end if;
      82
      83
      84          $   do load of input into -treg-.
dsj   65          getvar(inr, gd_inregnu, t, treg, moff);  $ load no update.
      86
      87          $   update register tracking status.  if last usage of
      88          $   input, assign new register to output.
dsg   10          if  ildr  then  $ assign to output.
      90              dr_reg dreg(outr) = treg;  $ set in -dreg- info.
      91              rl_content reglis(treg) = outr;  $ point -mreg- to -dreg-.
      92              rl_subtype reglis(treg) = rt_live;  $ show live.
      93              omreg = treg; omode = am_reg;  $ show output in regist
dsg   11              if  (oldr)  store(omreg, outr);
      94          else    $   assign to input.
      95              dr_reg dreg(inr) = treg;  $ set in -dreg- info.
      96              rl_content reglis(treg) = inr;  $ point -mreg- to -dreg-.
      97          rl_subtype reglis(treg) = rt_need;
      98              imreg = treg; imode = am_reg;  $ show input in registe
      99              end if;
     100          end if;
     101
     102
     103      $   if this is last usage of output and output is not
     104      $   assigned to a register, store into output.
     105      if  oldr & omode^=am_reg then   $ have this case.
     106 /storecase/  $   branched to from below.
     107          t = rl_type reglis(imreg);   $ save old status.
     108          store(imreg, outr);  $ store into output.
     109          rl_subtype reglis(imreg) = t;   $ restore register status.
     110          go to ret;  $ done.
     111          end if;
     112
     113      $   if input is not in a register and this is last usage of
     114      $   input, all work has been done so exit.
     115      if  (ildr & imode^=am_reg) go to ret;
     116
     117      $   otherwise, must copy input register into output register.
     118      rl_hold reglis(imreg) = yes;  $ just in case.
     119
     120      $   must get a register of the correct mode.  first
     121      $   check if the output is permanently assigned to a register.
     122      if  omode=am_reg then  $ it is -- use that register.
     123          treg = omreg;  $ set to output register.
     124      else    $   output not in register.
     125          getreg(treg, rt_need);  $ get register.
     126          end if;
     127
     128      $   if no register was assigned, go do store case.
     129      if  (treg = 0) go to storecase;  $ go store.
     130
     131      $   must check which load register operation to issue.
     132      $   note that if the assigned input register and the permanently
     133      $   assigned output register are of different modes, a load/store
     134      $   must be done to do the operation.
     135      mrcopy(treg, imreg); $ copy reg.
     136
     137      $   finally, update register status.
     138      rl_subtype reglis(treg) = rt_live;  $ set to live.
     139      rl_content reglis(treg) = outr; $ point -mreg- to -dreg-.
     140      dr_reg dreg(outr) = treg;  $ set to register number.
     141
     142 /ret/    $   common exit point.
     143      drop(outr);  drop(inr);  $ drop operands if last usage.
     144      end subr mover;
       1 .=member endsubr
       2      subr endsubr;  $ terminate processing of a routine.
       3      $   this routine is called after all code for a routine has been
       4      $   emitted.  -endsubr- then computes the location of each
       5      $   internal machine block in the program csect.  it then emits
       6      $   data, esd, and rld entries to initialize the base block and
       7      $   any other blocks such as the constant block.  in addition,
       8      $   it calls -outdata- to process data statements for any
       9      $   variables encountered.
      10      $   routine has been emitted.  it then emits
      11      $   data entries to initialize the base block and
      12      $   any other blocks such as the constant block.  in addition,
      13      $   it calls -outdata- to process data statements for any
      14      $   variables encountered.
      15      size  i(ps), j(ps), k(ps), t(ps);     $ temporaries.
      16      size  reg(ps);          $ dummy register.
      17      size  len(ps);          $ length.
      18      size  moff(mosize);     $ temporary.
      19
      20
      21      $   must put in code for return if return label is
      22      $   set.
      23      if  returnlab then  $ need code for return.
      24          labdef(returnlab, yes);  $ define label.
      25
      26          $   first, store all live permanent registers.
      27          do  i = r0 to rhi;  $ scan all possible.
      28              if  rl_type reglis(i) = rt_permlive then  $ must store.
      29                  store(i, rl_content reglis(i));   $ store back.
      30                  end if;
      31              end do;
      32
      33          $   if function, must load r0 .
      34          if  subrtype = st_fnct then  $ is function.
      35              assign(reg, va_fnct);  $ get register.
      36              lastuse(reg);  $ set status.
      37              forcezero(reg, ismw(reg));  $ force into r0.
      38              end if;
      39
      40          $   emit return operation.
      41          put ocsfile ,column(9) ,'ret' ,column(17)
vaxa 292 .+t10        :currsubname,a;
vaxa 293 .+t32        ;
      43          call ocsput(0, 0);  $ put code
      44          end if;
      45
dsq  102 .+t32.
dsq  103 $    output entry mask shifted right by two.
dsq  104 $    set overflow bit if want integer overflow traps.
dsq  105      size  maskword(ws);
dsq  106      maskword = .f. r2, rhi-r2+1, regmask;
dsq  107      if  iv_opt  then  $ if want overflow trap
dsq  108          .f. 15-2, 1, maskword = 1;  $ raise overflow traps.
dsq  109          end if;
dsu  124 .+t32h.
dsu  125      if  nsheap_this  then
dsu  126          .f. nsheapreg_w-2, 1, maskword = 1; $ using heap reg
dsu  127          .f. nsheapreg_b-2, 1, maskword = 1; $ using heap reg
dsu  128          end if;
dsu  129 ..t32h
dsq  110 ..t32
      46      put ocsfile ,column(9) ,'dec'  $ indicate end of code
vaxa 294 .+t10    ,column(17) :currsubname,a;
vaxa 295 .+t32    ,column(17)  :currsubname,a  ,','
dsq  111 .+t32    :maskword,b(0,4);
      48      call ocsput(0, 0);  $ put code.
      49      trace_c = no;  $ do not trace declarations.
      50
      51      mb_len mba(bl_base) = baselastaddr-1;   $ length of base block.
      52
vaxa 297 .+t10.
      53      $   allocate base block.
      54      if  baselastaddr>1  then  $ if base block.
      55          put ocsfile ,column(9) ,'dbw' ,column(17)
      56          :mblkname(bl_base),a  ,','  $ put block name.
      57          :baselastaddr-1,i;
      58          call ocsput(0, 0);  $ put code.
      59          end if;
vaxa 298 ..t10
vaxa 299
vaxa 300
vaxa 301 .+t32.
vaxa 302      $   allocate constant block.
vaxa 303      if  mb_len mba(bl_const)  then  $ there is a constant block.
vaxa 304          put  ocsfile ,column(9) ,'dbr' ,column(17)
vaxa 305              :mblknames(bl_const),a  ,','
vaxa 306              :(mb_len mba(bl_const))*mcpw,i;
vaxa 307          call ocsput(0, 0);  $ write out line.
vaxa 308          end if;
vaxa 309 ..t32
      60
      61      $   emit constants in constant block.
      62      i = mb_chain mba(bl_const);  $ get start of constant block.
      63      ddblk = bl_const;
dss   55      .s. 17, 3, ocs = mblkname(bl_const);  $ indicate constant block.
dss   56      .s. 20, 1, ocs = '+';
      65      while  i;
      66          ddoff = vv_madr voa(i) - (vv_syze voa(i) + (mws-1))/mws;
vaxa 310 .+t32    ddoff = ddoff * mcpw;  $ set to byte address.
dsw   21          call outcon(i,3);  $ put out value.
      68          i = vv_dimn voa(i);  $ link to next.
      69          end while;
      70
      71
vaxa 311 .+t32.
vaxa 312      $   allocate base block.
vaxa 313      if  mb_len mba(bl_base) then  $ if there is a base block.
vaxa 314          put  ocsfile ,column(9) ,'dbw' ,column(17)
vaxa 315              :mblknames(bl_base),a  ,','
vaxa 316              :(mb_len mba(bl_base)) * mcpw,i;
vaxa 317          call ocsput(0, 0);  $ write out line.
vaxa 318          end if;
vaxa 319 ..t32
dss   57      .s. 17, 3, ocs = mblkname(bl_base);  $ indicate base block.
dss   58      .s. 20, 1, ocs = '+';
      73      $   process entries in base block.
      74      i = basefirst;  $ point to first entry in block.
      75      while  i;  $ while more entries remain.
      76          j = bb_pointer baseblock(i);  $ get pointer from entry.
      77          ddoff = bb_addr baseblock(i) - 1;  $ dd offset.
vaxa 320 .+t32    ddoff = ddoff * mcpw;  $ set to byte pointer.
      78          go to bt(bb_type baseblock(i)) in 1 to num_bt; $ select type.
      79 /bt(bt_label)/  $ label entry.
      80      .s. 9, 3, ocs = 'dwa';  $ set code op.
      81      put ocsfile ,column(21)
      82          :ddoff,i ,','  $ put offset
dss   59          ,'l'
dss   60          :(lablorg + bb_pointer baseblock(i)) ,i(labcol,labcol);
      84          call ocsput(0, 1);  $ put line.
      85          go to contbase;  $ continue.
      86
      87 /bt(bt_plist)/  $ parameter lists.
vaxa 321 .+t32.  $ write out number of entries.
vaxa 322      .s. 9, 3, ocs = 'dwi';
vaxa 323      put  ocsfile  ,column(21) :ddoff,i  ,','
vaxa 324          :bb_nwords baseblock(i),i;
vaxa 325      call ocsput(0, 1);  $ write the line.
vaxa 326      ddoff = ddoff + mcpw;  $ count the word.
vaxa 327 ..t32
vaxa 328
vaxa 329
      88          .s. 9, 3, ocs = 'dwa';
eaa  183 .-t20.
      89      do  k = j to bb_nwords baseblock(i) + j-1;
      90          if  pd_block  pdlist(k)  then   $ if entry.
dsu  130 .+t32h.
dsu  131              if (nsheap_this=no) !
dsu  132         (nsheap_this & (pd_block pdlist(k) ^= nsheap_blk))  then
dsu  133 ..t32h
      91              put ocsfile ,column(21)
      92                  :ddoff,i ,','
      93                  :mblkname(pd_block pdlist(k)),a ,'+'
vaxa 330 .+t10            :pd_madr pdlist(k)-1,i;
vaxa 331 .+t32            :(pd_madr pdlist(k)-1) * mcpw, i;
      95              call ocsput(0, 1);  $ put line.
dsu  134 .+t32h           end if;
      96              end if;
vaxa 332 .+t10    ddoff = ddoff + 1;  $ step to next address.
vaxa 333 .+t32    ddoff = ddoff + mcpw;  $ step to next address.
      98          end do;
eaa  184
eaa  185 .+t20.
eaa  186      do  k = j to bb_nwords baseblock(i) + j - 1;
eaa  187          if  pd_block pdlist(k) then  $ if entry
eaa  188              if  nsheap_this & (pd_block pdlist(k) = nsheap_blk)  then
eaa  189                  .s. 9, 3, ocs = 'dha'; $ indicate heap address.
eaa  190                  put ocsfile ,column(21)
eaa  191                  :ddoff,i ,',efiw ('
eaa  192                  :nsheap_org,a ,'+'
eaa  193                  :pd_madr pdlist(k)-1,i ,',0)';
eaa  194              else  $ if not heap block
eaa  195                  put ocsfile ,column(21)
eaa  196                  :ddoff,i ,','
eaa  197                  :mblkname(pd_block pdlist(k)),a ,'+'
eaa  198                  :pd_madr pdlist(k)-1,i;
eaa  199                  end if;
eaa  200              call ocsput(0, 1); $ put line.
eaa  201              .s. 9, 3, ocs = 'dwa'; $ restore dwa op (in case was dha)
eaa  202              end if;
eaa  203          ddoff = ddoff + 1; $ step to next address.
eaa  204          end do;
eaa  205 ..t20
eaa  206
      99
     100      go to contbase;  $ continue.
     101
     102 /bt(bt_const)/  $ single word constants.
vaxa 334 .+t10    .s. 9, 3, ocs = 'dwo';  $ set op.
vaxa 335 .+t32    .s. 9, 3, ocs = 'dwh';  $ set op.
     104      put ocsfile ,column(21)
     105          :ddoff,i  ,','
vaxa 336 .+t10    :val(bb_pointer baseblock(i)),b(0,3);
vaxa 337 .+t32    :val(bb_pointer baseblock(i)),b(0,4);
     107      call ocsput(0, 1);  $ put line.
     108
     109 /bt(bt_temp)/
     110 /contbase/  $  continue.
     111          i = bb_chain baseblock(i);  $ chain to next entry;
     112          end while;
     113
     114      call ocsput(0, 2);  $ clear code line.
vaxa 338
vaxa 339
vaxa 340 .+t32.
vaxa 341      $   allocate temporary block.
vaxa 342      if  mb_len mba(bl_temp)  then  $ nonempty.
vaxa 343          put  ocsfile ,column(9)  ,'dbw' ,column(17)
vaxa 344              :mblknames(bl_temp),a  ,','
vaxa 345              :(mb_len mba(bl_temp)) * mcpw,i;
vaxa 346          call ocsput(0, 0);  $ write out line.
vaxa 347          end if;
vaxa 348 ..t32
vaxa 349
vaxa 350
     115      $   generate initial  values for variables in namesets
     116      $   defined in this procedure.
     117      do i = bl_local to mbaptr;  $ loop over nameset entries.
vaxa 351
vaxa 352
vaxa 353 .+t32.
vaxa 354          if  (mb_used mba(i) = no) cont do;
vaxa 355
vaxa 356
vaxa 357          if  i = bl_local then  $ this is local block.
vaxa 358              put  ocsfile ,column(9)  ,'dbw' ,column(17);
vaxa 359          elseif  mb_def mba(i) then
vaxa 360              sdsname(dopsname, (mb_ha mba(i)));  $ get block name.
dst   85$ emit dnd, unless nspage_opt selected, in which case emit pnd
dst   86          put ocsfile, column(9);
dst   87          if nspage_opt then put ocsfile,'pnd';
dst   88          else put ocsfile,'dnd';
dst   89          end if;
dst   90          put ocsfile ,column(17)
vaxa 362                  :dopsname,a  ,',';
vaxa 363          else    $   not local, not defined.
vaxa 364              sdsname(dopsname, (mb_ha mba(i)));  $ get name.
dst   91$ emit dna, unless nspage_opt selected, in which case emit pna
dst   92          put ocsfile, column(9);
dst   93          if nspage_opt then put ocsfile,'pna';
dst   94          else put ocsfile,'dna';
dst   95          end if;
dst   96          put ocsfile ,column(17)
vaxa 366                  :dopsname,a  ,',';
vaxa 367              end if;
vaxa 368
vaxa 369
vaxa 370          put  ocsfile  :mblknames(i),a  ,','   $ write internal name.
vaxa 371              :(mb_len mba(i)) * mcpw,i;
vaxa 372          call ocsput(0,0);
vaxa 374 ..t32
vaxa 375
vaxa 376
     118          if  (mb_def mba(i)=no)  cont do;
dsu  135 .+t20    if  nsheap_this & (i=nsheap_blk)  then cont do; end if;
     119          ddblk = i;
     120
     121              j = mb_chain mba(i);  $ point to first entry.
     122              while j; $ while more remain in chain.
     123                  len = ((vv_syze voa(j)+mws-1)/mws)*
     124                      (vv_dimn voa(j) + (vv_dimn voa(j)=0));
     125                  k = vv_madr voa(j) - ((vv_syze voa(j)+mws-1)/mws);
     126
     127 .-vvfrs      if  vv_frsdata voa(j) then $ must initialize.
     128 .+vvfrs              if  vvfrsdata(j) then $ must initialize.
     129                          call  outdata(j);  $ call data routine.
     130                          end if;
     131
     132                  j = vv_vbeg voa(j);  $ chain to next entry.
     133                  end while;
     134          end do;
     135
     136      call ocsput(0, 2);  $ put line.
     137
     138      .s. 9, 3, ocs = 'dep';  $ indicate end of procedure
     139      put ocsfile, column(17) :currsubname,a;
     140      call ocsput(0, 0);
vaxa 377
vaxa 378
vaxa 379 .+t32.  $ must write out real '.end' statement.
dsq  112      put ocsfile ,column(9)
dsq  113 .+t32u $ 'end' probably not required for unix bootstrap,but
dsq  114 .+t32u $ include for compatibility.
dsq  115 .+t32u   ,'end';
dsq  116 .+t32v   ,'.end';
vaxa 381      if  (subrtype = st_prog) put ocsfile ,column(17)
vaxa 382          :currsubname,a;  $ write out entry name if prog.
vaxa 383      call ocsput(0, 0);  $ write the line.
vaxa 384 ..t32
     141
     142
dss   61      totprocs = totprocs + 1;
     143      $   the rest of this processing is accumulation of statistics,
     144      $   so if they are not wanted, return.
     145      if  (lcs_opt = no) return;
     146
     147      $   else, start statistics by writing out lengths of blocks
     148      $   for this routine.
     149      textl(currsubname)      $ write routine name.
     151
     152      len = 0;  $ clear acumulation.
     153      tabl(30)  intl(mb_len mba(bl_const))
     154      len = len + mb_len mba(bl_const);
     155      tabl(40)  intl(mb_len mba(bl_base));
     156      len = len + mb_len mba(bl_base);
     157      tabl(50)  intl(codethis);
     158      len = len + codethis;
     159      tabl(60)  intl(mb_len mba(bl_local));
     160      len = len + mb_len mba(bl_local);
     161      tabl(70)  intl(mb_len mba(bl_temp))
     162      len = len + mb_len mba(bl_temp);
     163
     164      $   write out total module length.
     165      tabl(90)  intl(len)
     166      totlength = totlength + len;  $ add to total length.
     167
     168      len = 0;  $ clear cumulative global length.
     169      do  i = bl_global to mbaptr;
     170          if  mb_def mba(i)  then  $ if defined here, add in length.
     171              len = len + mb_len mba(i);  $ add to total.
     172              totglobs = totglobs + mb_len mba(i);
     173              totns = totns + 1;  $ count number of namesets.
     174              end if;
     175          end do;
     176
     177      tabl(100)  intl(len)  endl
     178
     179      $   reset variables to indicate which routine so far has
     180      $   used the most table space.
     181      if  pdlistp > loadpd then   $ this routine used most in -pdlist-
     182          loadpd = pdlistp; loadrpd = currsubname;
     183          end if;
     184
     185
     186
     187
     188
     189      if  labluse > loadlab then
     190          loadlab = labluse; loadrlab = currsubname;
     191          end if;
     192
     193      if  valptr > loadval then
     194          loadval = valptr; loadrval = currsubname;
     195          end if;
     196
     197      end subr endsubr;
       1 .=member outdata
       2      subr outdata(var);  $ this routine process data statements.
       3      $   this routine is called by -endsubr- to process any data
       4      $   statements on the chain of -var-.
       5      size  var(ps);          $ variable to process.
       6      size  dim(ps);          $ dimension of variable.
       7      size  curind(ps);       $ current index of variable.
       8      size  datvoa(ps);       $ -voa- pointer to data statement.
       9      size  wlen(ps);         $ word length of variable.
      10      size  i(ps), j(ps), k(ps);  $ temporaries.
      11      size  len(ps);          $ length of data item.
dsw   22      size  nlen(ps);   $ name length
      12      size  rep(ps);          $ repetition factor.
      13      size  vp(ps);               $ -voa- pointer to data value.
      14      size  vmadr(mps);        $ variable address.
      15
      16      $   first, set values for this variable.
      17      curind = 1;  $ initially at first element.
      18      dim = vv_dimn voa(var);  $ set dimension.
      19      if  (dim = 0) dim = 1;  $ reset if not array.
      20      wlen = (vv_syze voa(var) + (mws-1))/mws;  $ set word length.
      21      vmadr = vv_madr voa(var) - wlen;
      22      ddblk = vv_mblk voa(var);
      23
      24      $   process all data statements on chain for this variable.
      25 .-vvfrs  datvoa = vv_frsdata voa(var);  $ get first entry index.
      26 .+vvfrs  datvoa = vvfrsdata(var);  $ get first entry index.
      27
      28      .s. 9, 2, ocs = 'dw';  $ set declaritive op.
dsw   23      nlen = .len. mblkname(ddblk);
dsw   24      put ocsfile, column(17) :mblkname(ddblk),a ,'+';
      30
      31      while  datvoa;  $ loop while more remain.
      32          $   check if this is an overlapping index.
      33          if  vv_inp1 voa(datvoa) < curind then  $ it is.
      34              error('data indices overlap', var)
      35              quit while;
      36              end if;
      37
      38          curind = vv_inp1 voa(datvoa);  $ set current index.
      39          do  i = 1 to vv_arglen voa(datvoa);  $ process all elements.
      40              vp = xa_voa xarg(vv_argbeg voa(datvoa)+i-1);
      41              len = (vv_syze voa(vp)+(mws-1))/mws;
      42              rep = xa_rep xarg(vv_argbeg voa(datvoa)+i-1);
      43
      44              $   check if value too long.
      45              if  len > wlen then  $ too long.
      46                  error('data value too long', var)
      47                  quit while;
      48                  end if;
      49
      50              $   get repetition value.
      51              if  rep then  $ repetition is used.
      52                  rep = val(vv_vbeg voa(rep));  $ get constant value.
      53              else    $ will just do once.
      54                  rep = 1;
      55                  end if;
      56
      57              if  curind+rep>(dim+1)  then $ if out of range.
      58                  error('data index exceeds dimension', var);
      59                  quit while;
      60                  end if;
      61
      62              ddoff = vmadr +(curind-1) * wlen;
vaxa 385 .+t32        ddoff = ddoff * mcpw;  $ set to byte address.
      63              if  vv_naym voa(vp) = ha_0  then $ if zeroizing.
      64                  put ocsfile ,column(11) ,'z'  $ change op
dsw   25                  ,column(18+nlen) :ddoff,i, ','  $ put offset
      66                  :rep*wlen,i;
      67                  call ocsput(0, 1);  $ put line, retain text.
      68                  curind = curind + rep;
      69                  cont do;
      70                  end if;
      71
      72              do  j = 1 to rep;  $ do once/repetition.
      73
      74                  if  wlen-len > 0 then $ if must zero initial part.
      75                      put ocsfile ,column(11) ,'z'  $ change opcode.
dsw   26                      ,column(18+nlen)
      77                      :ddoff,i ,','  $ put offset.
      78                      :wlen-len,i;
      79                      call ocsput(0, 1);  $ put line, retain text.
      80                      end if;
      81
vaxa 386 .+t10            ddoff = ddoff + (wlen-len);
vaxa 387 .+t32            ddoff = ddoff + (wlen-len) * mcpw;
dsw   27                  call outcon(vp, nlen); $ put constant value.
      84                  curind = curind + 1;
vaxa 388 .+t10            ddoff = ddoff + len;
vaxa 389 .+t32            ddoff = ddoff + len*mcpw;
      86                  end do;
      87              end do;
      88
      89          k = datvoa;  $  save one entry back.
      90          datvoa = vv_inp2 voa(datvoa); $ get next data entry.
      91          end while;
      92
      93      end subr outdata;
       1 .=member outcon
dsw   28      subr outcon(voaptr, bl);  $ output constant initialization.
       3      size  voaptr(ps);    $ voa item to put out.
       4      size  tmi(ps);       $ index.
       5      size  tmwd(mws);     $ working copy of tmcval entry.
       6      size  c(mcs);        $ character.
       7      size  n(ps);         $ character count.
vaxa 390 .+t32    size  i(ps);     $ loop index.
       8      size  tmpos(ps);       $ position in word.
       9      size  ddtab(mcs);  dims ddtab(num_tmc);  $ type table
dsw   29      size  bl(ps);   $ length of block name
vaxa 391 .+t10    data  ddtab(tmc_b) = 1ro;
vaxa 392 .+t32    data  ddtab(tmc_b) = 1rh;
      11      data  ddtab(tmc_i) = 1ri;
      12      data  ddtab(tmc_c) = 1rc;
      13      data  ddtab(tmc_r) = 1rr;
dsn   87 .+t32  data  ddtab(tmc_s) = 1rs;
dsn   88 .+t10 data  ddtab(tmc_s) = 1rc;
      15
      16      ddlt = tmctab(vv_lextype voa(voaptr));
      17
      18      call tmcons(voaptr);  $ put into target machine form.
      19
vaxa 393 .-hmeqtm.
      20      .s. 9, 2, ocs = 'dw';
      21      .ch. 11, ocs = ddtab(ddlt);
vaxa 394 .+hmeqtm.
vaxa 395 .+t10    .s. 9, 3, ocs = 'dwo';
vaxa 396 .+t32    .s. 9, 3, ocs = 'dwh';
vaxa 397 ..hmeqtm
      22
      23      do  tmi = 1 to tmcvalptr;
      24          tmwd = tmcval(tmi);  $ copy entry.
dsw   30          put ocsfile ,column(18+bl)
vaxa 398 .+t10        :ddoff+tmi-1,i  ,',';
vaxa 399 .+t32        :ddoff + (tmi-1)*mcpw,i   ,',';
vaxa 400
vaxa 401
vaxa 402 .-hmeqtm.
      27          go to l(ddlt) in 1 to num_tmc;  $ branch on lexical type.
vaxa 403 ..hmeqtm
      28
      29      /l(tmc_b)/  $ bit string, put out in octal
vaxa 404 .+t10    put ocsfile :tmwd,b(0,3);
vaxa 405 .+t32    put ocsfile :tmwd,b(0,4);
      31          go to ddcont;
      32
vaxa 406 .-hmeqtm.
      33      /l(tmc_i)/  $ integer
      34          put ocsfile :tmwd,i;
      35          go to ddcont;
      36
      37      /l(tmc_r)/  $ real
      38          $   put out characters which are in same form
      39          $   as character constant (cf. tmc_c codein tmcons).
      40
vaxa 407          n = mcpw;  if (tmi=1) n = mod(ddnc-1, mcpw)+1;
vaxa 408          put ocsfile :tmwd,r(n);
      43          go to ddcont;
      44
      45      /l(tmc_c)/  $ character code (r) constant.
      46          n = mcpw;  if  (tmi=1)  n = mod(ddnc-1, mcpw) + 1;
vaxa 409 .+t10    tmpos = n*mcs+1;  $ position at left.
vaxa 410 .+t32    tmpos = 1;  $ position at right.
vaxa 411 .+t32    put  ocsfile ,'<';   $ write out macro arg. starter.
      48          put ocsfile :tmccdel,r(1);  $ put delimiter.
vaxa 412 .+t10.
dsn   89          tmpos = mws + 1 ;
dsn   90          do  n = 1 to mcpw ;
dsn   91              tmpos = tmpos - mcs ;
dsn   92              c = .f. tmpos, mcs, tmwd ;
dsn   93              if  c ^= 0
dsn   94              then
dsn   95                  if  ( c = tmccdel )  put  ocsfile  :tmccdel,r(1) ;
dsn   96                  put  ocsfile  :tmccdel,r(1) :c,r(1) :tmccdel,r(1) ;
dsn   97              end if ;
dsn   98              if  ( n ^= mcpw )  put  ocsfile  ,',' ;
dsn   99          end do ;
vaxa 413 ..t10
vaxa 414 .+t32.
vaxa 415          i = n;  $ save number of characters in word.
vaxa 416          until  n = 0;  $ until hit left end.
vaxa 417              n = n - 1;  $ decrement count.
vaxa 418              c = .f. tmpos, mcs, tmwd;  $ get a character.
vaxa 419              if  c = tmccdel then  $ this is delimiter.
vaxa 420                  put  ocsfile :c,r(1)  ,'/' :c,r(1) ,'/' :c,r(1);
vaxa 421              elseif  c = 1r< then  $ handle special character.
vaxa 422                  put  ocsfile :tmccdel,r(1) ,'<60>' :tmccdel,r(1);
vaxa 423              elseif  c = 1r> then  $ handle special character.
vaxa 424                  put  ocsfile :tmccdel,r(1) ,'<62>' :tmccdel,r(1);
vaxa 425              else    $ normal character.
vaxa 426                  put  ocsfile :c,r(1);
vaxa 427                  end if;
vaxa 428
vaxa 429
vaxa 430              tmpos = tmpos + mcs;  $ step to next character.
vaxa 431              end until;
vaxa 432
vaxa 433
vaxa 434          if  i ^= mcpw then  $ must insert zeros.
vaxa 435              do  n = 1 to mcpw-i;  $ mcpw-i times.
vaxa 436                  put  ocsfile :tmccdel,r(1) ,'<0>'
vaxa 437                      :tmccdel,r(1);
vaxa 438                  end do;
vaxa 439              end if;
vaxa 440
vaxa 441
vaxa 442          put  ocsfile ,'>';   $ close macro delimiter.
vaxa 443
vaxa 444
vaxa 445 ..t32
vaxa 446
vaxa 447
      55          put ocsfile :tmccdel,r(1);  $ put delimiter.
      56          go to ddcont;
      57
      58      /l(tmc_s)/  $ character string.
      59          if  tmi=tmcvalptr  then $ put last word as octal.
vaxa 448 .+t10        .ch. 11, ocs = 1ro;  go to l(tmc_b);
vaxa 449 .+t32        .ch. 11, ocs = 1rh;  go to l(tmc_b);
      61              end if;
      62          n = mcpw;  if (tmi=tmcvalptr-1) n=mod(ddnc,mcpw);
      63          if  (n=0)  n = mcpw;
vaxa 450 .+t32    put  ocsfile ,'<';   $ write out argument start.
      64          put ocsfile :tmcsdel,r(1);  $ put delimiter.
vaxa 451 .+t10.
      65          tmpos = mws+1;  $ start at leftmost position.
      66          until  n = 0;  $ until all characters are processed.
      67              n = n - 1;  $ count the character.
      68              tmpos = tmpos - mcs;  $ allow for the character.
      69              c = .f. tmpos, mcs, tmwd;  $ get character.
      70              put ocsfile :c,r(1);  $ put character.
      71              if  (c=tmcsdel)  put ocsfile :c,r(1); $ if delimiter.
      72              end until;
vaxa 452 ..t10
vaxa 453 .+t32.
vaxa 454          if  (n ^= mcpw) put ocsfile :4r    ,r(mcpw-n);  $ fill.
vaxa 455          tmpos = 1 + (mcpw-n) * mcs;  $ start at right.
vaxa 456          until  tmpos = mws+1;  $ until at end of word.
vaxa 457              c = .f. tmpos, mcs, tmwd;  $ get character.
vaxa 458              if  c = 1r< then  $ special case.
vaxa 459                  put  ocsfile :tmcsdel,r(1) ,'<60>'  :tmcsdel,r(1);
vaxa 460              elseif  c = 1r> then  $ another special case.
vaxa 461                  put  ocsfile :tmcsdel,r(1) ,'<62>'  :tmcsdel,r(1);
vaxa 462              else    $   normal character.
vaxa 463                  if  (c = tmcsdel)  $ if delimiter.
vaxa 464                      put  ocsfile :c,r(1) ,'/' :c,r(1) ,'/';
vaxa 465                  put  ocsfile :c,r(1);  $ write out character.
vaxa 466                  end if;
vaxa 467
vaxa 468
vaxa 469              tmpos = tmpos + mcs;  $ step to next position.
vaxa 470              end until;
vaxa 471
vaxa 472
vaxa 473          put  ocsfile  :tmccdel,r(1);
vaxa 474          put  ocsfile ,'>';   $ write argument terminator.
vaxa 475
vaxa 476
vaxa 477          $   now write out cleanly.
vaxa 478          i = filestat(ocsfile,column);
vaxa 479          put ocsfile ,x(57-i)  ,'; ' :tmccdel,r(1);
vaxa 480          do  i = 1 to n;  $ for each character.
vaxa 481              put  ocsfile :(.f. mws+1 - i*mcs, mcs, tmwd),r(1);
vaxa 482              end do;
vaxa 483 ..t32
vaxa 484
vaxa 485
      73          put ocsfile :tmcsdel,r(1);  $ put delimiter.
      74          go to ddcont;
vaxa 486 ..hmeqtm
      75
      76      /ddcont/  $ write out line
      77          call ocsput(0, 1);  $ retain 1-16.
      78          end do;
      79
      80      end subr outcon;
       1 .=member tmcons
       2      subr tmcons(voaptr);  $ convert target machine constant.
       3      $   given voa index -voaptr- of constant, convert as needed
       4      $   so that tmcval(1) to tmcval(tmcvalptr) contains constant
       5      $   in correct form for target machine.
       6      $   for resident compiler, this requires just copying over
       7      $   the contents of val array. for bootstrap, conversion
       8      $   depends on host machine structure, as val entries passed
       9      $   in form appropriate to host machine.
      10      size  c(cs);        $ character temporary
      11      size  hmpos(ps);      $ host machine word position.
      12      size  hmptr(ps);    $ host machine word pointer
      13      size  hmwd(ws);      $ temporary word value.
      14      size  i(ps);           $ loop index.
      15      size  nc(ps);          $ number of characters.
      16      size  nrem(ps);         $ remaining characters.
      17      size  mbs(szmax-1);       $ bit string to build target form.
      18      size  sz(ps);          $ result size.
      19      size  vl(ps);          $ vv_vlen value.
      20      size  vb(ps);          $ vv_vbeg value.
      21      size  vp(ps);          $ val pointer
      22      size  voaptr(ps);      $ voa index
      23
      24      vp = vv_vbeg voa(voaptr);  $ get starting point in val.
      25      vl = vv_vlen voa(voaptr);  $ get number of words in val.
      26      sz = vv_syze voa(voaptr);  $ get size.
      27      tmcvalptr = (sz+mws-1) / mws;   $ get target machine words.
      28      ddlt = tmctab(vv_lextype voa(voaptr));  $ save lexical type.
      29      ddnc = ha_nchars ha(vv_naym voa(voaptr));
vaxa 487 .+hmeqtm.  $ if host = target, just copy into tmcval.
      31      do  i = 1 to vl;  tmcval(i) = val(vp+i-1);  end do;
      32      if  (vl ^= tmcvalptr) call aermey(38);  $ error.
      33      return;
vaxa 488 ..hmeqtm
      35 .+s66.  $ on different host machine, reconvert.
      36      $   if result multiword on target, clear required
      37      $   part of mbs.
      38      do  i = 1 to (sz+ws-1)/ws+1;
      39          .f. (i-1)*ws+1, ws, mbs = 0;
      40          end do;
      41      go to l(ddlt) in 1 to num_tmc;
      42
      43 /l(tmc_i)/  $ integer, single word, so no conversion.
      44      tmcval(tmcvalptr) = val(vp);  $ no conversion
      45      if  (sz > mws) call aermey(38);  $ if too long.
      46      go to ret;
      47
      48 /l(tmc_b)/  $ bit, must format appropriate number to word.
      49      if  sz <= mws  then  $ if conversion not needed.
      50          tmcval(tmcvalptr) = val(vp);
      51          go to ret;
      52          end if;
      53      $   here to convert val packed hws bits to entry to
      54      $   target form.
      55      do  i = 1 to vl;
      56          .f. (vl-i)*ws+1, ws, mbs = val(vp+i-1);
      57          end do;
      58      go to retlong;
      59 /l(tmc_c)/  $ character code constant.
      60      $   host has passed characters left aligned, with blank
      61      $   fill.
      62      nc = ha_nchars ha(vv_naym voa(voaptr));
      63      if  (nc=0)  call aermey(39);
      64      hmpos = ws+1; hmptr = vp;  hmwd = val(hmptr);
      65      do  i = 1 to nc;
      66          hmpos = hmpos - cs;
      67          c = .f. hmpos, cs, hmwd;
vaxa 489          .e. (nc-i)*mcs + 1, mcs, mbs = c;
      69          if  hmpos = 1  then  $ if need new word.
      70              hmpos = ws+1;
      71              hmptr = hmptr + 1;
      72              hmwd = val(hmptr);
      73              end if;
      74          end do;
      75      go to retlong;
      76
      77 /l(tmc_r)/  $ real constant.
      78      $   convert in same way as for character constants.
      79      $   since real constants not 'safe' for bootstrap,
      80      $   val will just contain characters of constant.
      81
      82      go to l(tmc_c);
      83
      84 /l(tmc_s)/  $ character string.
      85      nc = ha_nchars ha(vv_naym voa(voaptr));
      86      if  nc = 0  then  $ if null string
      87          tmcval(1) = 0;  go to ret;  $ null string is zero.
      88          go to ret;
      89          end if;
      90      $   characters are packed in val, left aligned with
      91      $   blank fill.
      92      nc = ha_nchars ha(vv_naym voa(voaptr));
vaxa 490
vaxa 491
vaxa 492      hmpos = ws+1; hmptr = vp;  hmwd = val(hmptr); $ set up for start.
vaxa 493      do  i = 1 to nc;  $ process each character.
vaxa 494          hmpos = hmpos - cs;  $ step to next character.
vaxa 495          c = .f. hmpos, cs, hmwd;  $ get a character.
vaxa 496          .e. sz+1 - i*mcs, mcs, mbs = c;  $ insert character.
vaxa 497          if  hmpos = 1 then  $ if need new word.
vaxa 498              hmpos = ws+1;  $ reset.
vaxa 499              hmptr = hmptr + 1;  hmwd = val(hmptr);  $ get next word.
vaxa 500              end if;
vaxa 501          end do;
vaxa 502
vaxa 503
     102      $   fill in string origin, length field.
vaxa 504      .f. 1, msl, mbs = nc;  $ set length.
vaxa 505      .f. msl+1, mso, mbs = sz+1;  $ origin.
     105      go to retlong;
     106
     107 /retlong/  $ here to pack mbs to tmcval.
     108      do  i = 1 to tmcvalptr;
     109          tmcval(i) = .e. (tmcvalptr-i)*mws+1, mws, mbs;
     110          end do;
     111 ..s66
     112 /ret/
     113      end subr tmcons;
       1 .=member emopr
       2      subr emopr(op, oreg, imode, ireg, ioff);  $ emit machine instr.
       3      $   emit machine instruction for m op -op-.  oreg is accumulator
       4      $   and imode, ireg and ioff represent effect address.
       5
       6      size  op(ps);          $ mop
       7      size  oreg(ps);        $ result accumulator
       8      size  imode(ps);       $ input address mode.
       9      size  ireg(ps);        $ input machine register.
      10      size  ioff(mosize);    $ input block, offset.
      11      size  regname(.sds. 3);  dims regname(16);
      12      size  blk(ps);       $ block of address.
      13      size  off(mps);      $ offset of address.
      14      size  ic(cs);           $ immediate code.
      15      size  ostr(.sds. namelen);       $ for output description.
      16      size  nx(ps);              $ space count.
dsu  136        size  mvop(1); $ set if mvw or mvx op
      17
      18      codethis = codethis + moaiwc(op);  $ add length of instr.
      19      .s. 9, 3, ocs = moptab(op);
pic   14 .+t32v
pic   15      pic_case=no;
pic   16      if (op=mo_lda ! op=mo_ldw ! op=mo_stw )
pic   17      & (imode=am_rel ! imode=am_reli) &
pic   18        (mbo_blk ioff > bl_imm) then
pic   19        pic_case=yes;
pic   20        pic_char = .ch. 10, ocs;
pic   21        .ch. 10, ocs = 1rx;
pic   22      end if;
pic   23 ..t32v
      20
dsu  137      mvop = (op=mo_mvw) ! (op=mo_mvx);
vaxa 506 .+t10.
      21      $   if op admits immediate mode and operand is immediate,
      22      $   append i to opcode.
      23      if  mbo_blk ioff = bl_imm then  $ if immediate block.
      24          if  (moaimm(op) = no) call aermey(40);  $ ***assign number***
      25          put ocsfile ,column(12) ,'i';
      26          end if;
vaxa 507 ..t10
      27
      28      put ocsfile ,column(17);
      29      call emitea(am_reg, oreg, 0);
      30      put ocsfile ,',';
      31      ostr = strname;
dsu  138 .+t32h.
dsu  139      if mvop ! op=mo_lpr ! op=mo_spr ! op=mo_bnb
dsu  140         ! op=mo_bfb then
dsu  141          if  nsheap_this then
dsu  142              nsheap_byte = yes;
dsu  143              end if;
dsu  144          end if;
dsu  145 ..t32h
      32      call emitea(imode, ireg, ioff);
dsu  146 .+t32h    nsheap_byte = no;
      33
      34      $   now put out any additional operands needed for specific ops.
vaxa 508 .+t10.
dsu  147      if  op = mo_lpr ! op = mo_spr ! mvop then
      36          put ocsfile ,',' :emopparm1,i;  $ write parm. 1.
      37
dsu  148          if  mvop=0 then  $ there is a second parm.
      39              put ocsfile ,',' :emopparm2,i;  $ write second.
      40              end if;
      41          end if;
vaxa 509 ..t10
vaxa 510 .+t32.
vaxa 511      size  mode(ps), reg(ps), moff(mosize);
dsu  149      if  mvop then  $ if word move.
dsq  117          put  ocsfile ,',' ,tmcslit
dsq  118              :emopparm1,i;  $ write out extra operand.
vaxa 514
vaxa 515
vaxa 516      elseif  op = mo_lpr ! op = mo_spr then  $ field operation.
vaxa 517          put  ocsfile ,',';  $ write a comma.
vaxa 518          getdesc(emopparm1, gd_use, mode, reg, moff);   $ get first bit
dsu  150 .+t32h   nsheap_byte = yes;
vaxa 519          call emitea(mode, reg, moff);  $ write the ea.
dsu  151 .+t32h   nsheap_byte = no;
vaxa 520          getdesc(emopparm2, gd_use, mode, reg, moff);  $ get length.
vaxa 521          put  ocsfile  ,',';  $ write a comma.
dsu  152 .+t32h   nsheap_byte = yes;
vaxa 522          call emitea(mode, reg, moff);  $ write the ea.
dsu  153 .+t32h   nsheap_byte = no;
vaxa 523          end if;
vaxa 524 ..t32
      42
      43      if  slen strname ^= 0 ! slen ostr ^= 0  then
      44          nx = 17 - mod(filestat(ocsfile,column), 8);
      45          $   [ds 31 may  separate nx reflects gen bug in nested
      46          $   filestat handling.]
dsq  119          put ocsfile ,x(nx) ,tmcscom;
      48          if  (slen ostr)  put ocsfile :ostr,a;
      49          if  slen strname  then
      50              if  (slen ostr)  put ocsfile ,',';
      51              put ocsfile :strname,a;
      52              end if;
      53          end if;
      54
pic   24 .+t32v  pic_case=no;
      55      call ocsput(0, 0);  $ put line.
vaxa 525
vaxa 526
vaxa 527 .+t32.
vaxa 528      if  op = mo_lpr ! op = mo_spr then  $ field operations.
vaxa 529          drop(emopparm1);  drop(emopparm2);  $ drop parameters.
vaxa 530          end if;
vaxa 531 ..t32
vaxa 532
vaxa 533
      56      end subr emopr;
       1 .=member emitea
       2      subr emitea(mode, reg, ioff);  $ put out ea.
       3      $   emit t10 code for operand.
       4      size mode(ps);           $ operand mode.
       5      size reg(ps);            $ machine register
       6      size  ioff(mosize);        $ operand block, offset
       7      size  blk(ps),  off(mps);   $ block, offset.
       8      size  i(ps);  $ temporary.
vaxa 534      size  sign(cs);         $ sign character (1r+ or 1r-).
       9
      10      $   free output register.
      11      rl_hold reglis(reg) = no;  $ no longer on hold.
      12      reguseval = reguseval + 1;  $ increment usage count.
      13      rl_usevalue reglis(reg) = reguseval;  $ save lru value.
vaxa 535 .+t32    .f. reg, 1, regmask = yes;  $ show register used.
      14
      15      .len. strname = 0;  $ clear name string.
      16      i = rl_content reglis(reg);  $ assume data.
      17      if  (rl_subtype reglis(reg) = rt_address
      18          ! rl_subtype reglis(reg) = rt_liveaddr)
      19          & (i^=0)  then
      20          i = dw_freg dword(di_lword ditem(i));
      21          end if;
      22
      23      if  reg ^= sparereg & i^=0  then  $ if not empty.
      24          if  isvar(i)  then  $ if variable.
      25              sdlname(strname, (vv_naym voa(di_chain
      26                  ditem(dr_item dreg(i)))));  $ get name.
      27              end if;
      28          end if;
      29
      30      blk = mbo_blk ioff;  off = mbo_off ioff;  $ get block, offset.
eaa  208 .+t20.
eaa  209      if  nsheap_this & (blk=nsheap_blk)  then  $ if need to redirect.
eaa  210          call emitex(mode, reg, off, blk);
eaa  211          return;
eaa  212          end if;
eaa  213 ..t20
dsu  154 .+t32h.
dsv   11$ only redirect if offset>0, i.e., keep refs to heap_adr as is
dsva   1      if nsheap_this & (blk=nsheap_blk) & .not.(mode=am_mem & off=0)
dsva   2          then  call emiteh(mode, reg, off, blk);
dsu  157          return;
dsu  158          end if;
dsu  159 ..t32h
      31      $   dispose of am_reg case.
      32      if  mode=am_reg  then
      33          put ocsfile ,'r' :reg-1,i;
      34          return;  end if;
      35      if  mode=am_reli  then  $ if indirect.
dsq  120          put ocsfile ,tmcsind;  end if;
      37      $   identify block unless immediate or  absolute.
vaxa 536 .+t10    if  blk>bl_imm  then  $ if need to identify.
vaxa 537 .+t32    if  blk>=bl_imm  then  $ if need to identify.
dsq  121 .+t32.
pic   25 .+t32u.
pic   26      if  (mode=am_rel & blk>bl_imm) put ocsfile ,'l' :tmccgra,r(1);
pic   27 ..t32u
pic   28 .+t32v.
pic   29 $ pic form
pic   30      if blk>bl_imm then put ocsfile ,'g^'; end if;
pic   31 ..t32v
dsq  125          ;
dsq  126 ..t32
      39          put ocsfile :mblkname(blk),a;
      40          end if;
      41      $   indicate offset, as negative if sign bit set.
vaxa 539
vaxa 540
vaxa 541      if  .f. mps, 1, off then  $ if negative.
vaxa 542          off = mneg(off);  sign = 1r-;  $ set negative.
vaxa 543      else    $ positive.
vaxa 544          sign = 1r+;  $ show positive.
vaxa 545          end if;
vaxa 546
vaxa 547
vaxa 548 .+t32.
vaxa 549      if  (blk ^= bl_imm) off = off * mcpw;  $ set to byte value.
vaxa 550      if  mode = am_mem ! off ^= 0 then
vaxa 551 ..t32
vaxa 552          put  ocsfile :sign,r(1)  :off,i;  $ write out offset.
vaxa 553 .+t32    end if;
      45      $   write index register if appropriate.
      46      if  mode=am_rel ! mode=am_reli  then
vxaa   1 .+t10     put ocsfile ,'(r' :reg-1,i ,')';
vaxa 555 .+t32.
pic   32 .+t32u.
vaxa 556          if  reg = parmreg
vaxa 557          then   put  ocsfile ,'(ap)';
vaxa 558          else   put  ocsfile ,'(r' :reg-1,i  ,')'; end if;
pic   33 ..t32u
pic   34 .+t32v.
pic   35      if reg=parmreg then put ocsfile ,'(ap)';
pic   36      elseif blk>bl_imm then $ if need pic form then
pic   37          put ocsfile ,'[r' :reg-1,i ,']';
pic   38      else put ocsfile ,'(r' :reg-1,i ,')';
pic   39          end if;
pic   40 ..t32v
vaxa 559 ..t32
      48          end if;
      49      if  mode=am_mem  then
      50          if  (reg^=sparereg)  call aermey(33);  end if;
      51      end subr emitea;
dsu  160 .+t32h.
dsu  161      subr emiteh(mode, reg, off, blk);  $ put out ea.
dsu  162      $   emit t10 code for operand.
dsu  163      size mode(ps);           $ operand mode.
dsu  164      size hreg(ws);  $ reg if dynamic address
dsu  165      size reg(ps);            $ machine register
dsu  166      size  blk(ps),  off(mps);   $ block, offset.
dsu  167      size  i(ps);  $ temporary.
dsu  168      size  sign(cs);         $ sign character (1r+ or 1r-).
dsu  169
pic   41 .+t32v.
pic   42      if pic_case  then  $ no need pic fix for heap refs
pic   43        .ch. 10, ocs = pic_char;
pic   44      end if;
pic   45 ..t32v
dsu  170      $   dispose of am_reg case.
dsu  171      if  mode=am_reg  then
dsu  172          put ocsfile ,'r' :reg-1,i;
dsu  173          return;  end if;
dsu  174      if  mode=am_reli  then  $ if indirect.
dsu  175          put ocsfile ,tmcsind;
dsu  176          end if;
dsu  177      $   indicate offset, as negative if sign bit set.
dsu  178
dsu  179
dsu  180      if  .f. mps, 1, off then  $ if negative.
dsu  181          off = mneg(off);  sign = 1r-;  $ set negative.
dsu  182      else    $ positive.
dsu  183          sign = 1r+;  $ show positive.
dsu  184          end if;
dsu  185
dsu  186        if (blk ^= bl_imm) off = off * mcpw; $ convert to bytes
dsu  187
dsu  188      $   write index register if appropriate.
dsu  189      if  mode=am_rel ! mode=am_reli  then
dsu  190          if off ^= 0 then
dsu  191          put  ocsfile :sign,r(1)  :off,i;  $ write out offset.
dsu  192          end if;
dsu  193          if  reg = parmreg
dsu  194          then   put  ocsfile ,'(ap)';
dsu  195          else   put  ocsfile ,'(r' :reg-1,i  ,')'; end if;
dsu  196      else $ put out @#off[rh]
dsv   13          put ocsfile ,tmcsind ,tmcslit :off,i;
dsu  198          if sign^=1r+ then call aermey(99); end if;
dsu  199              end if;
dsu  200
dsu  201      if nsheap_byte then hreg = nsheapreg_b;
dsu  202      else hreg = nsheapreg_w; end if;
dsu  203      put ocsfile ,'[r' :hreg-1,i ,']'; $ add indexing
dsu  204      if  mode=am_mem  then
dsu  205          if  (reg^=sparereg)  call aermey(33);
dsu  206          end if;
dsu  207
dsu  208      end subr emiteh;
dsu  209 ..t32h
eaa  214 .+t20.
eaa  215      subr emitex(mode, reg, off, blk);  $ put out ea.
eaa  216      $   emit t20 code for operand.
eaa  217      size mode(ps);           $ operand mode.
eaa  218      size hreg(ws);  $ reg if dynamic address
eaa  219      size reg(ps);            $ machine register
eaa  220      size  blk(ps),  off(mps);   $ block, offset.
eaa  221      size  i(ps);  $ temporary.
eaa  222      size  sign(cs);         $ sign character (1r+ or 1r-).
eaa  223
eaa  224      $   dispose of am_reg case.
eaa  225      if  mode=am_reg  then
eaa  226          put ocsfile ,'r' :reg-1,i;
eaa  227          return;  end if;
eaa  228      if  mode=am_reli  then  $ if indirect.
eaa  229          call aermey(1); $ cannot have indirection here!!!
eaa  230          put ocsfile ,tmcsind;
eaa  231          end if;
eaa  232 $ write operand as @[heaporg + offset +register_specification]
eaa  233      put ocsfile ,'@[efiw ' :nsheap_org,a;
eaa  234      $   indicate offset, as negative if sign bit set.
eaa  235
eaa  236
eaa  237      if  .f. mps, 1, off then  $ if negative.
eaa  238          off = mneg(off);  sign = 1r-;  $ set negative.
eaa  239      else    $ positive.
eaa  240          sign = 1r+;  $ show positive.
eaa  241          end if;
eaa  242
eaa  243
eaa  244      put  ocsfile :sign,r(1)  :off,i;  $ write out offset.
eaa  245      $   write index register if appropriate.
eaa  246      if  mode=am_rel ! mode=am_reli  then
eaa  247          put ocsfile ,',' :reg-1,i ,']';
eaa  248      else put ocsfile ,',0]';
eaa  249          end if;
eaa  250
eaa  251      if  mode=am_mem  then
eaa  252          if  (reg^=sparereg)  call aermey(33);
eaa  253          end if;
eaa  254      end subr emitex;
eaa  255 ..t20
       1 .=member ocsput
       2      subr ocsput(la, c);  $ put code line.
       3      size  la(ps);       $ length argument.
       4      size  l(ps);       $ length.
       5      size  c(ps);       $ action code.
dsq  128 .+hmeqtm.
dsq  129      size  s(.sds. 80);   $ copy of code string
dsq  130 ..hmeqtm
       6      $   c=0 to clear 1-16 after write.
       7      $   c=1 to retain 1-16 after write.
       8      $   c=2 to clear 1-16, no write.
       9
      10      if  c = 2  then  $ if clear only wanted.
      11          .s. 1, 16, ocs = '';
      12          return;
      13          end if;
      14      l = la;  if (l=0)  l = filestat(ocsfile,column)-1;
dsq  131 .-hmeqtm.
      15      put codefile :ocs,a(l) ,skip;  $ put to codefile.
dsr   15 ..hmeqtm
      16      if  (trace_c)  put :ocs,a(l) ,skip;  $ put trace to print file.
dsq  133 .+hmeqtm.
dsq  134 $    here to try to generate tabs.
dsq  135 $    cannot alter ocs, so work with copy in s.
dsq  136
dsq  137      s = ocs;  .len. s = l;
dsq  138      if  l>8  then  $ try to map initial blanks to tabs
dsq  139          if .s. 1, 8, s .seq. (''.pad.8)  then
dsq  140              .ch. 1, s = tmcctab;  $ insert tab
dsq  141              .s. 2, l-8, s = .s. 9, l-8, s;
dsq  142              l = l - 7;
dsq  143              .len. s = l;
dsq  144              $  now try to put tab in operator field
dsq  145              if  l > 9  then
dsq  146                  if .s. 5, 5, s .seq. (''.pad.5)  then
dsq  147                      .ch. 5, s = tmcctab;
dsq  148                      .s. 6, l-9, s = .s. 10, l-9, s;
dsq  149                      l = l - 4;  $ adjust length.
dsq  150                      .len. s = l;
dsq  151                      end if;
dsq  152                  end if;
dsq  153              end if;
dsq  154          end if;
dsq  155      put codefile :s,a(l) ,skip;  $ put to codefile.
dsq  156 ..hmeqtm
      17      if  (c = 0) .s. 1, 16, ocs = '';
      18      end subr ocsput;
       1 .=member basprb
       2      subr baseprober(ctyp, optr, ihcode, p1, p2, arrayp, array);
       3      $   this routine is called by the various -baseprobe- macros
       4      $   to insert items into the hased base block.  -ctyp- is the
       5      $   call type and determines some of the actions.
       6      size  ctyp(ps);         $ calling type.
       7      size  optr(ps);         $ the output pointer.
       8      size  ihcode(mws/2+7);     $ the given hash code.
       9      size  p1(ps);           $ one descriptive parameter.
      10      size  p2(ps);           $ the second parameter.
      11      size  arrayp(ps);       $ array pointer to data.
      12      size  array(ps);        $ index value representing array.
      13      size  hcode(23);        $ computed hash code to use.
      14      size  ptr(ps);          $ base block pointer.
      15      size  type(ps);         $ entry type.
      16      size  len(ps);          $ entry length.
      17      size  i(ps), j(ps);     $ temporaries.
      18      size  vptr(ps);         $ desired data pointer.
      19      size  baseent(baseblocksz);  $ temporary entry.
      20
      21      $   first must set the values for this probe based on
      22      $   the calling type.
      23      if  ctyp = rp_addlab then  $ label call.
      24          type = bt_label; $ set type.
      25          len = 1;  $ labels are one word long.
      26          vptr = p2;  $ data pointer is label index.
      27          hcode = p2;  $ hashcode is initially label index.
      28      elseif  ctyp=rp_nocomp  then
      29          len = p1;  type = p2;
      30          vptr = arrayp;  $ data pointer is array pointer.
      31          hcode = vptr;  $ initial hash code is pointer.
      32      else    $ this is normal call.
      33          len = p1;  type = p2;  $ get length, type.
      34          vptr = arrayp;  $ set data pointer to array pointer.
      35          hcode = ihcode;  $ use caller's hash code.
      36          end if;
      37
      38      $   complete hash code with type and length.
      39      .f. mws/2+1, 3, hcode = type;  $ insert type.
      40      .f. mws/2+4, 3, hcode = len;   $ insert length.
      41
      42      $   compute initial place to try in base block.
      43      ptr = mod(hcode, baseblockprime);  $  compute initial probe.
      44      if  (ptr = 0) ptr = baseblockprime - 2;  $ set for bad value.
      45
      46      $   enter a loop which will be exited when a free entry
      47      $   is found.
      48      until  yes;  $ will exit when found entry.
      49          $   if the first one is free, quit now.
      50          if  (bb_type baseblock(ptr) = 0) quit until;
      51
      52          $   scan and see if the desired entry is already in the
      53          $   base block.
      54          while  yes;  $ will quit when end of chain found.
      55              $   must compare each entry.  quit this next
      56              $   loop if the entries do not match.
      57              until  yes;  $ quit if no match.
      58                  $   in the case of the -addlab- call, will
      59                  $   just say that they dont compare.
      60                  if  (ctyp = rp_addlab) quit until;
      61
      62                  $   check types.
      63                  if  (bb_type baseblock(ptr) ^= type) quit until;
      64
      65                  $   next check lengths.
vaxa 560 .+t10            if  (bb_nwords baseblock(ptr) < len) quit until;
vaxa 561 .+t32            if  (bb_nwords baseblock(ptr) ^= len) quit until;
      67
      68                  $   if the pointers compare, the items are the
      69                  $   same.  so return this pointer.
      70                  if  bb_pointer baseblock(ptr) = vptr then  $ found.
      71                      optr = ptr;  return;  $ set return value.
      72                      end if;
vaxa 562
vaxa 563
      73                  if  (ctyp ^= rp_normal) quit until;
      74
      75                  $   finally, check every word in the data.
vaxa 564 .+t32            if len then  $ if there is a list.
      76                  do  i = 0 to len-1;  $ check every entry.
      77                      $   do the array comparison that is needed.
      78                      j = bb_pointer baseblock(ptr)+i;  $ get one value.
      79                      if  array = ar_val then  $ compare const array.
      80                          if  (val(vptr+i) ^= val(j)) quit until;
      81                      else $ parm. lists.
      82                          if  (pdlist(vptr+i) ^= pdlist(j)) quit until;
      83                          end if;
      84                      end do;
vaxa 565 .+t32                end if;
      85
      86                  $   found a matching entry at a different
      87                  $   location.  therefore, the entry in the array
      88                  $   that is pointed to is redundant.  so if the
      89                  $   pointer is set to the last used value, can
      90                  $   update the last used value.
      91                  if  (vptr = rparrmx - (len-1)) rparrmx = vptr - 1;
      92
      93                  $   return pointer.
      94                  optr = ptr;  return;
      95                  end until;
      96
      97              $   this entry is not the one wanted.  see if more in
      98              $   clash chain.
      99              if  (bb_link baseblock(ptr) = 0) quit while;  $ no more.
     100              ptr = bb_link baseblock(ptr);  $ else get pointer.
     101              end while;
     102
     103          $   must look for a free entry from the top of the array.
     104          do  i = baseblockfree to 1 by -1;  $ scan down.
     105              if  (bb_type baseblock(i)) cont do;  $ not free.
     106              baseblockfree = i-1;  $ update free pointer.
     107              bb_link baseblock(ptr) = i;  $ add to clash chain.
     108              ptr = i;  $ point to entry.
     109              quit until;  $ show found entry.
     110              end do;
     111
     112          $   else, base block is full.
     113          call aermey(26);  $ this is a fatal error.
     114          end until;
     115
     116      $   finally, build entry.
     117      optr = ptr;  $ set return value.
     118
     119      baseent = 0;  $ set entry to null.
     120      bb_type baseent = type;  $ set type.
     121      bb_nwords baseent = len;  $ set length.
     122      bb_pointer baseent = vptr;  $ set data pointer.
     123
     124      baseblock(ptr) = baseent;   $ place in block.
     125
     126      $   if type is constant, will not assign address now.
     127      if  (type = bt_const) return;  $ so just return.
     128
     129      $   assign address and chain to entries whose address have
     130      $   been assigned.
     131      bb_addr baseblock(ptr) = baselastaddr;  $ set address.
     132      if  baselast then  $ this is not first in chain.
     133          bb_chain baseblock(baselast) = ptr;  $ chain last to this.
     134      else    $ this is first in chain.
     135          basefirst = ptr;  $ show is first.
     136          end if;
     137
     138      baselast = ptr;  $ show last in chain.
     139      baselastaddr = baselastaddr + len;  $ increment base block address
vaxa 566 .+t32    if  (array = ar_plist) baselastaddr = baselastaddr + 1;
     140
     141
     142      end subr baseprober;
       1 .=member countup
       2      subr countupr(name);  $ process array overflow.
       3      $   this routine informs the user of an array overflow
       4      $   and terminates the compilation.
       5      size  name(.sds. namelen);   $ name of array.
       6
       7      terml(yes)  textl(error_notice) textl('array ') textl(name)
       8      textl(' overflowed.  compilation aborted.') endl
       9      textl('assembling ') textl(currsubname)  endl
      10      errno = errno+1;
      11
      12      exitcode = 1; call asmexit;  $ terminate compilation.
      13      end subr countupr;
       1 .=member aermey
       2      subr aermey(n);  $ print fatal error message.
       3      $   this routine is called to print fatal error messages
       4      $   and abort the compilation.
       5      size  n(ps);                $ error message number.
       6      size  i(ps);                $ temporary.
       7
       8      +*  ender = go to ret; **  $ abbreviation.
       9
      10      terml(yes) textl(system_notice)  $ write header.
dse   26      if  n <= 0 ! n >= 42 then  $ bad number.
      12          tintl('bad message number', n) ender
      13          end if;
      14
rka   12      go to e(n) in 1 to 41;  $ print error message.
      16
      17 /e(1)/   tintl('invalid error number', n) ender
      18 /e(2)/   textl('chaining error in label fixup') ender
      19 /e(3)/   textl('format error on voa file') ender
      20 /e(4)/   textl('unconverted return found') ender
      21 /e(5)/   textl('invalid call to -assignr-') ender
      22 /e(6)/   textl('inreg points to free item') ender
      23 /e(7)/   textl('dummy item table is full') ender
      24 /e(8)/   textl('dummy word table is full') ender
      25 /e(9)/   textl('dummy register table is full') ender
      26 /e(10)/  textl('bad temporary drop status') ender
      27 /e(11)/  textl('attempt to clear address-float item') ender
      28 /e(12)/  textl('attempt to clear temporary') ender
      29 /e(13)/  textl('-ditem- on free chain twice') ender
      30 /e(14)/  textl('-dword- on free chain twice') ender
      31 /e(15)/  textl('-dreg- on free chain twice') ender
      32 /e(16)/  textl('bad address value with no register') ender
      33 /e(17)/  textl('bad call to -inzeror-') ender
      34 /e(18)/  textl('bad call to -moveaddr-') ender
      35 /e(19)/  textl('bad non-commutative operation') ender
      36 /e(20)/  textl('not last word received in -emitsub-') ender
      37 /e(21)/  textl('more than one word on chain') ender
      38 /e(22)/  textl('no base register available') ender
      39 /e(23)/  textl('not last word of arg. in -getdescr-') ender
      40 /e(24)/  textl('bad unassigned address') ender
      41 /e(25)/  textl('cannot get register pair') ender
      42 /e(26)/  textl('base block is full') ender
      43 /e(27)/  textl('disagreeing values in store of addrlive') ender
      44 /e(28)/  textl('bad input to store addrlive') ender
      45 /e(29)/  textl('cannot obtain space in -dops-') ender
      46 /e(30)/  textl('live address present at block end') ender
      47 /e(31)/  textl('improper drop status of temporaries') ender
      48 /e(32)/  textl('attempt to drop permanent value') ender
      49 /e(33)/  textl('reg should be sparereg') ender
      50 /e(34)/  textl('unexpected gdfdreg call') ender
      51 /e(35)/  textl('invalid address mode') ender
      52 /e(36)/  textl('bad dopcode') ender
      53 /e(37)/  textl('premature end on voa file') ender
      54 /e(38)/  textl('constant conversion problem') ender
      55 /e(39)/  textl('lablist overflow')  ender
      56 /e(40)/  textl('expect immediate mode') ender
dse   27 /e(41)/  textl('-in2- not constant for idt/imt')  ender
      57
      58 /ret/        $ common termination code.
      59      endl endl  $ leave some space.
rke   12      terml(no);
      60
      61 .+trace.     $ print info. describing error.
dso   13       if  n ^= 13 & n ^= 14 & n ^= 15 & n ^= 21 then
      62          tintl(' at error dopcode', dopcode)
      63          tintl('voaep', voaep) tintl('vopcode', vopcode)
      64          endl tintl('       dopir', dopir) tintl('dopjr', dopjr)
      65          tintl('dopkr', dopkr) tintl('dopor', dopor)
      66          tintl('dopnargs', dopnargs) tintl('dopnx', dopnx) endl
      67          call dumpdregs; call dumpmregs;
dso   14           end if;
      68 ..trace
      69
      70      exitcode = 1; call asmexit;  $ terminate.
      71
      72      end subr aermey;
       1 .=member asmexit
       2      subr asmexit;  $ code generator termination routine.
       3      $   this routine terminates the code generation.  it prints
       4      $   statistics, closes files, and writes messages to the user.
       5      size  totwaste(ps);         $ total wasted space.
       6
       7      $   first, write statistics if user wants them.
       8      if  lcs_opt then  $ statistics wanted.
       9          terml(no)  $ just in case.
      10          call stitlr(1, 'statistics for this code generation.');
      11          ejectlp(13) endl  $ start at new page if near end.
      12
      13          $   write out length statistics.
      14
      15          if  totprocs>1  then $ if several procs, give total length.
      16              intl(totprocs) textl(' procedures, estimate ')
      17              intlp(totlength, 6)  textl(' words.')  endl
      18              end if;
      19
      20          if  totns>1  then  $ if several namesets, give total length.
      21              intl(totns) textl(' namesets with ')
      22              intlp(totglobs, 6)  textl(' words.')  endl
      23              end if;
      24
      25          endl
      26
      27          textl('compiler array usage') endl
      28          textl('array name') tabl(19)
      29          textl('length') tabl(30)
      30          textl(' used ') tabl(39)
      31          textl('unused') tabl(50)
      32          textl('procedure') endl
      33
      34          +*  arastat(lib, max, tot, rout, sz) =  $ print line.
      35              textl(lib) tabl(20)
      36              intl(max) tabl(30)
      37              intl(tot) tabl(40)
      38              intl(max-tot) tabl(50)
      39              textl(rout) endl
      40              totwaste = totwaste + (max-tot);
      41              **
      42
      43          totwaste = 0;  $ show nothing wasted yet.
      44          arastat('pdlist', pdlistdim, loadpd, loadrpd, 1);
      45
      46          arastat('lablist',lablistdim,loadlab,loadrlab,lablistsz/ws);
      47          arastat('val', valdim, loadval, loadrval, 1);
      48          tabl(20)  textl('unused array words')
      49          tabl(40)  intl(totwaste)
      50          endl
dst   97 .+enp.
dst   98      if enpopt  then $ report if unmatched procedures
dst   99        tintl('enptot',enptot) tintl(' enporg',enporg) endl
dst  100          if enpnotfound then
dst  101              textl('enp procs not found ') intl(enpnotfound)
dst  102              endl
dst  103              end if;
dst  104           end if;
dst  105 ..enp
      51          endl endl macdrop(arastat)
      52          end if;
      53
      54      $   write out number of errors.
      55      terml(yes)   $ want this on terminal file.
      56      if  errno then  $ there were errors.
      57          intl(errno) textl(' detected errors.') endl
      58      $   s37 setcc code to set condition code dropped.
      59      $   check if s10 has any equivalent of s37 cnndition code.
      62          end if;
      63
      64      $   close any open files.
      65      file voafile access=release;
      66
dsp   45 .+t10.
dsp   46      $   if -end- option selected, see if want special last line
dsp   47      if  end_opt .seq. 'prg'  then  $ if want end of program.
dsp   48          put ocsfile ,column(9) ,'extern  z$strt';
dsp   49          call ocsput(0, 0);
dsp   50          put ocsfile ,column(9) ,'end     z$strt';
dsp   51          call ocsput(0, 0);
dsp   52      elseif  end_opt .seq. 'seg'  then  $ if want end of segment.
dsp   53          put ocsfile ,column(9) ,'end';
dsp   54          call ocsput(0, 0);
dsp   55      elseif  end_opt .sne. '0'  then  $ if want endnam
dsp   56          put ocsfile ,column(9), 'end' :end_opt,a;
dsp   57          call ocsput(0, 0);
dsp   58          end if;
dsp   59 ..t10
dsp   60
      67      $   process possible abnormal termination.
      68      if  exitcode then  $ this is abnormal.
      69          textl(error_notice) textl('abnormal termination.') endl
      70          call ltlxtr; terml(no); call clsterm; call ltlfin(1,1);
      71          end if;
      72
      73      terml(no); call clsterm;  $ else just close terminal file.
dsi   10      call ltlterm(3, 0);    $ terminate normally.
      75
      76      end subr asmexit;
       1 .=member note
       2 .+docnote.
       3     report on initial work on little compiler for dec-10
       4
       5                        richard kenner
       6                        david shields
       7
       8                         2 june 1978
       9
      10  the goal of this project is to produce a resident little compiler
      11  for the digital equipment corporation decsystem-10 (dec-10).
      12  work began last summer during a visit to nyu by anthony p. mccann
      13  of the university of leeds.  it was decided to base the code
      14  generator on that written by kenner for the ibm system/370 (s37).
      15  initial work consisted largely of taking the 370-dependent parts
      16  of the asm code out of the s37 asm, while retaining underlying
      17  machine-independent code genertion machinery.
      18
      19  shields visited mccann at leeds in early april 1978.  the design
      20  was reviewed, as well as structure of operating system interface.
      21  nigel chapman, a graduate student at leeds, also joined the
      22  project at that time.
      23
      24  it was agreed that the bootstrap compiler would produce source code
      25  for a made-up machine called t10 (t stands for target) in order to
      26  simplify bootstrap onto the dec-10.  t10 admits a straightforward
      27  translation to dec-10 assembler (which is called macro-10).
      28
      29  the bootstrap asm has been used to translate the little library,
      30  as well as the utility programs ltldoc and ltlpad (a copy of
      31  ltldoc may be found in the guide to the little language).  a
      32  correct assembly of ltldoc was obtained at the dec-10 at bbn in
      33  boston, although it was not possible to run the code as the
      34  operating system interface for dec-10 is not yet available.
      35
      36  kenner and shields are now shipping the compiler for mccann and
      37  chapman for further checkout.  they will write operating system
      38  interface, check system out, and then hopefully be in position
      39  to request translation of the little compiler itself.  once
      40  bootstrap to dec-10 effected, it is planned to convert compiler
      41  to produce binary object (rel) files directly, as well as to
      42  further refine the code generator.
      43
      44  a goal in writing the 370 code generator was to produce a base
      45  for constructing other code generators.  the work on the dec-10
      46  has gone quite smoothly.  as the dec-10 architecture is much cleaner
      47  than the 370, the asm is correspondingly simpler.
      48
      49  the rest of this note contains the following
      50
      51  1.  description of dec-10
      52  2.  a comment separating program in little
      53  3.  the t10 code produced for separating program
      54  4.  the dec-10 macro code for separating program
      55  5.  a small test program used in asm checkout
      56  6.  the t10 code produced by test program
      57  7.  the macro-10 macros for t10 opcodes used for
      58      assembly at bbn.
      59
      60  section 1.  brief introduction to the dec-10
      61  --------------------------------------------
      62
      63  this section contains a brief description of the dec-10
      64  hardware.  basic machine characters are as follows:
      65
      66  1.  word size of 36.
      67  2.  memory up to 256k.
      68  3.  address size of 18 bits.
      69  4.  character size varies, but will be six for first
      70      little implementation.
      71  5.  halfword, byte and stack instructions.
      72  6.  no condition codes.
      73  7.  first sixteen memory locations are 'fast' and correspond
      74      to registers, which may be addressed as memory, accumulators
      75      or index registers.
      76  8.  arithmetic is two's complement.
      77  9.  memory protection and relocation.  memory may be divided
      78      into 'pure' (high) and 'impure' (low) segments, typically
      79      done so pure segment can contain sharable, reentrant code.
      80
      81  the basic instruction word layout is as follows:
      82
      83      ic = .f. 28, 09,  instruction code
      84      ra   .f. 24, 04,  result accumulator (register) number
      85      ia   .f. 23, 01,  set for indirect addressing
      86      ir   .f. 19, 04,  index register (if nonzero)
      87      ma   .f. 01, 18,  memory address
      88
      89  the rightmost three fields ia, ir and ma determine the
      90  effective address e in the same way in all instructions,
      91  as follows:
      92
      93      $   is is current instruction word.
      94      aw = .f. 01, 24, iw;
      95      while 1;  $ while possible indirection.
      96          e = .f. 01, 18, aw;  $ get memory address.
      97          if  .f. 19, 04, aw  then  $ if indexing
      98              e = e + memory(.f. 19, 04, aw);  $ do indexing.
      99              end if;
     100          if  (.f. 23, 1, aw = 0)  quit while;  $ if not indirect.
     101          aw = .f. 1, 24, memory(e);  $ indirect, load next word.
     102          end while;
     103
     104  here, memory(x) indicates contents of memory location x.
     105
     106  the assembler is called macro-10.  basic assembler conventins
     107  are as follows:
     108  1.  symbols up to six characters, may use period, dollar sign
     109      and percent characters in symbols
     110  2.  labels indicated by initial name followed by colon.
     111  3.  first operand generally result register, second generally
     112      specifies effective address.
     113  4.  symbol '.' indicates current location.
     114  5.  comments begin with semicolon.
     115  6.  literals enclosed in square brackets.  literals may
     116      be multi-line, i.e., contain several instructions.
     117
     118  for example, the instruction
     119      move  r1,@ara(r2)  ; load ara(i) into r1.
     120  (where @ is that 'at' character)
     121  moves a value into register r1.  the value is obtained by
     122  adding the contents of register r2 (here used as an index
     123  register) to ara to obtain address e and, since @ indicates
     124  indirect addressing, the contents of location e contain the
     125  address of the operand.
     126
     127  the dec-10 ops are straightforward.  the common form specifies
     128  result register and memory address, and indicates the contents
     129  of register and memory operand are to be combined in some way.
     130  there are four basic modes for most of the instructions:
     131
     132    (basic)   put result in register
     133    (memory)  put result in memory
     134    (immediate) put result in register, ea is value to operate
     135                on, not address of operand
     136    (both)    put result in both register and memory
     137
     138  the default mode is basic; other modes are indicated by adding
     139  letter m, i or b to opcode to obtain memory, immediate, or
     140  both, respectively.
     141
     142  the dec-10 supports the field extract as a hardware operation,
     143  sothat code generation for extractions is very straightforward
     144  the machine operation uses a byte pointer where the i, x and
     145  y fields address the word containing the byte.  the leftmost
     146  six bits of the byte pointer define the byte position p, the
     147  next six bits define the byte size s.  s is the number of bits
     148  in the byte, and p is the number of bits in the word to the
     149  right of the rightmost bit in the byte.  thus
     150
     151      little  .f. f1, f2, v  corresponds  to s=f2  p=f1-1
     152
     153  macro supports a pseudo-op 'point' to construct byte pointers
     154  which has the form
     155
     156      point  s1,a,b1
     157
     158  where a is the address of the word containing the byte, s1 is
     159  the length of byte, and b1 is the dec-10 index of the rightmost
     160  bit of the byte.  thus
     161
     162      point  s1,a,b1  corresponds to  s=s1, p=35-b1
     163
     164  so that
     165
     166      little  .f. f1, f2, v  corresponds to  s1=f2, b1=36-f1
     167
     168  example of field extract
     169
     170      r2 = .f. 2, 10, r1  -->  ldb  r2,[point 10,r1,34]
     171
     172
     173
     174  section 2.  little program to separate comments
     175  ------------------------------------------------------
     176
     177   this a simple little program that filters the input
     178   file to align dec-10 format assembler comments.
     179   ---------------------------------------------------
     180
     181        $   program to align semicolon comments in dec-10 code.
     182        $   semicolons in input text are assumed to begin
     183        $   comments.  comments not beginning in column one are
     184        $   aligned so that comments begin in a tab column (1,9,17,...).
     185        $   author:  d. shields  (cims)  1 jun 78
     186        +*  ws = .ws. **  +* ps=.ps.**  +* cs=.cs.**
     187        +*  ofile = 3 **   $ output file.
     188        prog main;
     189        size  istr(.sds. 80);   $ input string.
     190        size  sp(ps);           $ semicolon position
     191        size  nsp(ps);          $ new semicolon position.
     192
     193        file ofile access=put, title='out',linesize=80;
     194   .+s66   rewind ofile;
     195
     196        while 1;  $ filter std. input to ofile.
     197            get ,skip :istr,a(80);
     198            if  (filestat(1,end)) quit while;
     199            sp = ';' .in. istr;
     200            $   just copy if no semicolon, or semicolon is aligned.
     201            if  sp=0 ! mod(sp,8)=1  then
     202                put ofile :istr,a ,skip;
     203            else  $ if semicolon to align.
     204                nsp = sp+8-mod(sp-1,8);
     205                put ofile
     206                    :(.s. 1,sp-1,istr),a  $ text.
     207                    ,column(nsp) ,';'     $ semicolon
     208                    :(.s. sp+1,(80-nsp),istr),a  $ comment text.
     209                    ,skip;
     210                end if;
     211            end while;
     212        end prog;
     213
     214
     215
     216  section 3.  t10 code for semicolon program
     217  ------------------------------------------
     218
     219          search  t10mac
     220          dsp     main,0,2                ; * * * m a i n ***
     221  ;=      istr         g10+16
     222  ;=      sp           g10+0
     223  ;=      nsp          g10+1
     224          dnd     $ain,g10,17
     225          dbr     con,4
     226          dbw     tmp,15
     227          dsc     main
     228          cal     ltlini,1,bas+1
     229          cal     makf$i,6,bas+5
     230    lab l0001
     231          cal     vali$i,2,bas+12
     232          cal     gcfp$i,2,bas+15
     233          cal     ifma$i,2,bas+18
     234          cal     ioqu$i,2,bas+15
     235          jne     r0,l0002
     236          cal     cind$m,2,bas+21
     237          stw     r0,g10+0                ;sp
     238          ldw     r11,r0          ;sp
     239          bani    r11,+7
     240          jeq     r0,l0006
     241          ceqi    r11,+1
     242          jmp     r0,l0003
     243    lab l0006
     244          cal     vali$i,2,bas+26
     245          cal     ofma$i,2,bas+29
     246          cal     gcfp$i,2,bas+15
     247          jmp     r0,l0001
     248    lab l0003
     249          ldw     r11,g10+0
     250          iso     r10,r11                 ;sp
     251          ldw     r9,r11          ;sp
     252          iadi    r9,+8
     253          ldw     r8,r10
     254          bani    r8,+7
     255          isu     r9,r8
     256          stw     r9,g10+1                ;nsp
     257          cal     vali$i,2,bas+26
     258          stw     r10,bas+23
     259          cal     cext$m,5,bas+32
     260          cal     ofma$i,2,bas+37
     261          cal     gcfp$i,2,bas+39
     262          cal     ofma$i,2,bas+42
     263          iao     r11,r11                 ;sp,sp
     264          ldwi    r10,+80
     265          isu     r10,g10+1
     266          stw     r11,bas+20
     267          stw     r10,bas+23
     268          cal     cext$m,5,bas+44
     269          cal     ofma$i,2,bas+37
     270          cal     gcfp$i,2,bas+15
     271          jmp     r0,l0001
     272    lab l0002
     273          cal     ltlfin,2,bas+49
     274          dec     main
     275          dbw     bas,51
     276          dws     con+0,"out"
     277          dwo     con+1,111000003
     278          dws     con+2,";"
     279          dwo     con+3,111000001
     280          dwo     bas+0,0
     281          dwa     bas+1,bas+0
     282          dwo     bas+2,3
     283          dwo     bas+3,7
     284          dwo     bas+4,120
     285          dwa     bas+5,bas+2
     286          dwa     bas+6,bas+3
     287          dwa     bas+7,con+1
     288          dwa     bas+8,bas+2
     289          dwa     bas+9,bas+4
     290          dwa     bas+10,bas+0
     291          dwo     bas+11,1
     292          dwa     bas+12,bas+11
     293          dwa     bas+13,bas+0
     294          dwo     bas+14,2
     295          dwa     bas+15,bas+11
     296          dwa     bas+16,bas+14
     297          dwo     bas+17,207000240
     298          dwa     bas+18,g10+16
     299          dwa     bas+19,bas+17
     300          dwa     bas+21,con+3
     301          dwa     bas+22,g10+16
     302          dwa     bas+26,bas+2
     303          dwa     bas+27,bas+11
     304          dwo     bas+28,207000000
     305          dwa     bas+29,g10+16
     306          dwa     bas+30,bas+28
     307          dwo     bas+31,17
     308          dwa     bas+32,bas+11
     309          dwa     bas+33,bas+23
     310          dwa     bas+34,g10+16
     311          dwa     bas+35,tmp+14
     312          dwa     bas+36,bas+31
     313          dwa     bas+37,tmp+14
     314          dwa     bas+38,bas+28
     315          dwa     bas+39,g10+1
     316          dwa     bas+40,bas+11
     317          dwo     bas+41,22000000
     318          dwa     bas+42,con+3
     319          dwa     bas+43,bas+41
     320          dwa     bas+44,bas+20
     321          dwa     bas+45,bas+23
     322          dwa     bas+46,g10+16
     323          dwa     bas+47,tmp+14
     324          dwa     bas+48,bas+31
     325          dwa     bas+49,bas+0
     326          dwa     bas+50,bas+0
     327          dep     main
     328
     329
     330  section 4.  hand translation of t10 code for semicolon
     331  -------------------------------------------------------
     332
     333          search  t10mac
     334          title   main
     335          twoseg
     336          entry   main
     337          reloc   0
     338  z$sa:   block   13      ;register save area.
     339  ;=      istr         g10+16
     340  ;=      sp           g10+0
     341  ;=      nsp          g10+1
     342          intern  $ain
     343  $ain:   block   17
     344  g10==$ain
     345  con:    block   4
     346  tmp:    block   15
     347          reloc   ^o400000        ;code in high segment
     348  main:   movei   r13,z$sa
     349          blt     r13,z$sa+r11-1  ;save registers
     350          movei   r12,bas+1
     351          pushj   r15,ltlini
     352          movei   r12,bas+5
     353          pushj   r15,makf$i
     354  l0001:  movei   r12,bas+12
     355          pushj   r15,vali$i
     356          movei   r12,bas+15
     357          pushj   r15,gcfp$i
     358          movei   r12,bas+18
     359          pushj   r15,ifma$i
     360          movei   r12,bas+15
     361          pushj   r15,ioqu$i
     362          jumpn   r0,l0002
     363          movei   r12,bas+21
     364          pushj   r15,cind$m
     365          movem   r0,g10+0                ;sp
     366          move    r11,r0          ;sp
     367          andi    r11,+7
     368          jumpe   r0,l0006
     369          move    r12,r11
     370          movei   r11,+1
     371          caie    r12,+1
     372          setz    ,r11
     373          jumpa   r0,l0003
     374  l0006:  movei   r12,bas+26
     375          pushj   r15,vali$i
     376          movei   r12,bas+29
     377          pushj   r15,ofma$i
     378          movei   r12,bas+15
     379          pushj   r15,gcfp$i
     380          jumpa   r0,l0001
     381  l0003:  move    r11,g10+0
     382          move    r10,r11
     383          sos     r10,
     384          move    r9,r11          ;sp
     385          addi    r9,+8
     386          move    r8,r10
     387          andi    r8,+7
     388          sub     r9,r8
     389          movem   r9,g10+1                ;nsp
     390          movei   r12,bas+26
     391          pushj   r15,vali$i
     392          movem   r10,bas+23
     393          movei   r12,bas+32
     394          pushj   r15,cext$m
     395          movei   r12,bas+37
     396          pushj   r15,ofma$i
     397          movei   r12,bas+39
     398          pushj   r15,gcfp$i
     399          movei   r12,bas+42
     400          pushj   r15,ofma$i
     401          aos     ,r11                 ;sp
     402          movei   r10,+80
     403          sub     r10,g10+1
     404          movem   r11,bas+20
     405          movem   r10,bas+23
     406          movei   r12,bas+44
     407          pushj   r15,cext$m
     408          movei   r12,bas+37
     409          pushj   r15,ofma$i
     410          movei   r12,bas+15
     411          pushj   r15,gcfp$i
     412          jumpa   r0,l0001
     413  l0002:  movei   r12,bas+49
     414          pushj   r15,ltlfin
     415          dec     main
     416          lit
     417          reloc   ;return to lo segment.
     418  bas     block   51
     419          .org    con+0
     420          sixbit  "out"
     421          oct     111000003
     422          sixbit  ";"
     423          oct     111000001
     424          .org
     425          .org    bas+0
     426          oct     0
     427          exp     bas+0
     428          oct     3
     429          oct     7
     430          oct     120
     431          exp     bas+2
     432          exp     bas+3
     433          exp     con+1
     434          exp     bas+2
     435          exp     bas+4
     436          exp     bas+0
     437          oct     1
     438          exp     bas+11
     439          exp     bas+0
     440          oct     2
     441          exp     bas+11
     442          exp     bas+14
     443          oct     207000240
     444          exp     g10+16
     445          exp     bas+17
     446          exp     con+3
     447          exp     g10+16
     448          exp     bas+2
     449          exp     bas+11
     450          oct     207000000
     451          exp     g10+16
     452          exp     bas+28
     453          oct     17
     454          exp     bas+11
     455          exp     bas+23
     456          exp     g10+16
     457          exp     tmp+14
     458          exp     bas+31
     459          exp     tmp+14
     460          exp     bas+28
     461          exp     g10+1
     462          exp     bas+11
     463          oct     22000000
     464          exp     con+3
     465          exp     bas+41
     466          exp     bas+20
     467          exp     bas+23
     468          exp     g10+16
     469          exp     tmp+14
     470          exp     bas+31
     471          exp     bas+0
     472          exp     bas+0
     473          .org
     474          lit
     475          var
     476          prgend  main
     477
     478
     479
     480  section 5.  tst10 - asm test program
     481  ------------------------------------
     482
     483
     484
     485      prog start;
     486      call sub1;
     487      end prog;
     488      subr sub1;
     489      size  mw1(.ws.*3), mw2(.ws.*2);
     490      size  mwfcn(.ws.*2), f(.ps.);
     491      size  i(.ps.), j(.ps.);
     492
     493      i = .f. 1, 1,j;  i = .f. 1, 1, mw1;
     494
     495      mw1 = 0;  mw2 = mwfcn(i);
     496
     497      j = .f. i+1, 3, f(j);
     498
     499      j = .f. 1, i, mw2;
     500
     501      .f. 1, 1,i = 1;
     502
     503      .f. 1, 4, i = j;
     504
     505      .f. i, j, mw2 = 567;
     506
     507      i = .f. 1, 2, 67;
     508
     509      end subr sub1;
     510      fnct mwfcn(x);
     511      size mwfcn(2*.ws.), x(.ws.);
     512
     513      mwfcn = x;
     514
     515      end fnct;
     516      fnct f(i);
     517      size  f(.ps.), i(.ps.);
     518
     519      f = .f. 19, 18, i;
     520
     521      end fnct;
     522      subr sub2;
     523      size  mwarr(.ws.*2), swarr(.ws.);
     524      dims  mwarr(100), swarr(100);
     525
     526      size  i(.ps.);
     527
     528      mwarr(i) = i;
     529
     530      swarr(i) = i + 3;
     531
     532      mwarr(i) = mwarr(i+4);
     533
     534      call sub3(mwarr, swarr);
     535
     536      end subr sub2;
     537      subr sub3(mwarr, swarr);
     538      size  mwarr(.ws.*2), swarr(.ws.);
     539
     540      dims mwarr(2), swarr(2);
     541      size  i(.ps.);
     542
     543      swarr(1) = 20;
     544
     545      .f. 1, 3, mwarr(i) = 5;
     546
     547      .f. i+1, 5, swarr(i) = 20;
     548
     549      end subr sub3;
     550
     551
     552
     553 $ little dec10 code generator test.
     554      +* ws = .ws. ** +* ps=.ps. **  +* cs = .cs.**
     555      subr main;
     556      size  gw1(ws), gw2(ws), gw3(ws), gw4(ws);
     557     size  i(ps), ara(ws); dims ara(100);
     558      data gw1=1;
     559      gw1 = gw2 + gw3;
     560      do  i = 1 to .nb. gw1; ara(i) = ara(i) / 4; end do;
     561      if  gw1>gw2 & gw3>=1  then  i = 10;  else i= gw1*gw2; end if;
     562      if  gw1 .ne. gw2 ! i<0  then
     563          call sub(gw1, ara(i+2), 4);
     564          end if;
     565      size mw1(ws*3), mwa(ws*3); dims mwa(5);
     566      call sub1(mw1, mwa, mwa(4));
     567      end subr;
     568
     569
     570
     571
     572  section 6.  generated t10 code for tst10 program
     573  ------------------------------------------------
     574        search  t10mac
     575        dsp     start,0,2               ; * * * s t a r t * * *
     576        dsc     start
     577        cal     ltlini,1,bas+1
     578        cal     sub1,0,0
     579        cal     ltlfin,2,bas+2
     580        dec     start
     581        dbw     bas,4
     582        dwo     bas+0,0
     583        dwa     bas+1,bas+0
     584        dwa     bas+2,bas+0
     585        dwa     bas+3,bas+0
     586        dep     start
     587        search  t10mac
     588        dsp     sub1,0,0                ; * * * s u b 1 * * *
     589  ;=      mw1          lcl+9
     590  ;=      mw2          lcl+4
     591  ;=      i            lcl+1
     592  ;=      j            lcl+2
     593          dbw     tmp,2
     594          dbw     lcl,10
     595          dsc     sub1
     596          ldw     r1,lcl+1                ;i
     597          ldw     r2,lcl+2                ;j
     598          lpr     r11,r2,0,1              ;j
     599        ldw     r1,r11          ;i
     600        lpr     r11,lcl+9,0,1
     601        ldw     r1,r11          ;i
     602        lda     r11,lcl+7
     603        zebi    r11,+3
     604        stw     r1,lcl+1                ;i
     605        cal     mwfcn,1,bas+1
     606        ldw     r10,r0
     607        lda     r9,lcl+3
     608        mvw     r9,-1(r10),2
     609        cal     f,1,bas+3
     610        lda     r10,r0
     611        spr     r1,r10,30,6             ;i
     612        ldwi    r8,+3
     613        spr     r8,r10,24,6
     614        ldf     r10,r10
     615        ldw     r2,r10          ;j
     616        lda     r10,lcl+4
     617        spr     r1,r10,24,6             ;i
     618        ldf     r10,r10
     619        ldw     r2,r10          ;j
     620        ldwi    r10,+1
     621        spr     r10,r1,0,1              ;i
     622        spr     r2,r1,0,4               ;j,i
     623        iso     r8,r1           ;i
     624        ldw     r7,r8
     625        idii    r7,+36
     626        imoi    r8,+36
     627        ico     r7,r7
     628        lda     r6,lcl+4(r7)
     629        lda     r7,+0(r6)
     630        spr     r8,r7,30,6
     631        spr     r2,r7,24,6              ;j
     632        ldwi    r8,+567
     633        stf     r8,r7
     634        lpr     r10,bas+5,0,2
     635        ldw     r1,r10          ;i
     636  lab l0002
     637        stw     r1,lcl+1                ;i
     638        stw     r2,lcl+2                ;j
     639        ret     sub1
     640        dec     sub1
     641        dbw     bas,6
     642        dwa     bas+1,lcl+1
     643        dwa     bas+3,lcl+2
     644        dwo     bas+5,103
     645        dep     sub1
     646        search  t10mac
     647        dsp     mwfcn,1,1               ; * * * m w f c n * * *
     648;=      x            @+0(r11)
     649;=      mwfcn        bas+1
     650        dsc     mwfcn
     651        lda     r10,bas+0
     652        zebi    r10,+1
     653        ldw     r9,@+0(r11)
     654        stw     r9,bas+1                ;mwfcn
     655  lab l0003
     656        lda     r0,bas+1
     657        ret     mwfcn
     658        dec     mwfcn
     659        dbw     bas,2
     660        dep     mwfcn
     661        search  t10mac
     662        dsp     f,1,1                   ; * * * f * * *
     663;=      i            @+0(r11)
     664;=      f            bas+0
     665        dsc     f
     666        ldl     r10,@+0(r11)
     667        stw     r10,bas+0
     668  lab l0004
     669        ldw     r0,bas+0
     670        ret     f
     671        dec     f
     672        dbw     bas,2
     673        dep     f
     674        search  t10mac
     675        dsp     sub2,0,0                ; * * * s u b 2 * * *
     676;=      mwarr        lcl+102
     677;=      swarr        lcl+1
     678;=      i            lcl+0
     679        dbw     tmp,2
     680        dbw     lcl,301
     681        dsc     sub2
     682        ldw     r1,lcl+0                ;i
     683        ldw     r11,r1          ;i
     684        imti    r11,+1
     685        lda     r10,lcl+99(r11)
     686        zebi    r10,+1
     687        stw     r1,lcl+100(r11)                 ;i
     688        ldw     r11,r1          ;i
     689        iadi    r11,+3
     690        stw     r11,lcl+0(r1)           ;i
     691        ldw     r11,r1          ;i
     692        imti    r11,+1
     693        lda     r10,lcl+108(r11)
     694        ldw     r11,r1          ;i
     695        imti    r11,+1
     696        lda     r9,lcl+99(r11)
     697        mvw     r9,-1(r10),2
     698        cal     sub3,2,bas+2
     699  lab l0005
     700        stw     r1,lcl+0                ;i
     701        ret     sub2
     702        dec     sub2
     703        dbw     bas,4
     704        dwa     bas+2,lcl+102
     705        dwa     bas+3,lcl+1
     706        dep     sub2
     707        search  t10mac
     708        dsp     sub3,2,0                ; * * * s u b 3 * * *
     709;=      mwarr        @+0(r11)
     710;=      swarr        @+1(r11)
     711;=      i            lcl+0
     712        dbw     lcl,1
     713        dsc     sub3
     714        ldw     r1,lcl+0                ;i
     715        ldw     r10,+1(r11)
     716        ldwi    r9,+20
     717        ldw     r8,r1           ;i
     718        imti    r8,+1
     719        ldw     r7,+0(r11)
     720        ldw     r6,r8
     721        iad     r6,r7           ;mwarr
     722        lda     r5,-2(r6)
     723        ldwi    r8,+5
     724        spr     r8,+0(r5),0,3
     725        stw     r9,+0(r10)              ;swarr,swarr
     726        ldw     r7,r1           ;i
     727        iad     r7,r10          ;swarr
     728        lda     r5,-1(r7)
     729        lda     r10,+0(r5)
     730        spr     r1,r10,30,6             ;i
     731        spr     r8,r10,24,6
     732        ldwi    r9,+20
     733        stf     r9,r10
     734  lab l0006
     735        stw     r1,lcl+0                ;i
     736        ret     sub3
     737        dec     sub3
     738        dbw     bas,2
     739        dep     sub3
     740
     741
     742
     743  section 7.  macro-10 macros for t10 operations
     744  ----------------------------------------------
     745
     746  this section contains a preliminary definition
     747  of the dec-10 macro-10 macros to expand t10
     748  code to valid macro-10 code.  this version
     749  is based in part on a version written by nigel
     750  chapman of leeds in april 78.  this version was
     751  used to assemble the little program ltldoc.
     752  there were no assembly errors.  as the system
     753  interface for dec-10 little was not available, it
     754  was not possible to run the program.
     755
     756          universal       t10mac
     757  ;       t10 macros for assembling t10 code.
     758  ;       these macros expand the t10 source code generated
     759  ;       by little dec-10 bootstrap compiler into macro-10
     760  ;
     761  ;       author  d. shields    cims     1-jun-78
     762  ;
     763  ;       the macros should be assembled as a universal file
     764          pass2  ;  no data, so need only pass2.
     765          radix   10
     766  ;       symbols used within macros all begin with  z$ .
     767  ; symbolic names for registers.
     768  r0==0
     769  r1==1
     770  r2==2
     771  r3==3
     772  r4==4
     773  r5==5
     774  r6==6
     775  r7==7
     776  r8==8
     777  r9==9
     778  r10==10
     779  r11==11
     780  rhi==r11
     781  w1==rhi+1
     782  w2==rhi+2
     783  z$sp==15
     784  ; r0 is used to hold function value.
     785  ; t10 code uses registers ro through rhi.
     786  ; w1 and w2 are work registers used in some
     787  ; macro expansions.  w1 is volatile in that
     788  ; t10 code may contain uses of w1 to store
     789  ; values into parameter lists.
     790  ; z$sp is stack pointer used for procedure
     791  ; linkage.
     792  ;
     793  ; z$pt. codes give procedure type: subr, fnct
     794  ;       or prog.  this is same encoding used
     795  ;       by gen, and is passed as last arg
     796  ;       in dsp t10 opcode.
     797  z$pt.s==0
     798  z$pt.f==1
     799  z$pt.p==2
     800          define  dbr(bn,l)
     801  
     802          define  dbw(bn,l)
     803  
     804          define  dec(pn)
     805  <       lit  ; hi seg literals
     806          reloc>  ; return to low segment
     807          define  dep(pn)
     808  <       lit
     809          var
     810          ife     z$pt-z$pt.p,
     811          ifn     z$pt-z$pt.p,>
     812          define  dsc(pn)
     813  <       reloc ^o400000  ;; code in high  segment
     814  pn:     movei   w2,z$sa
     815          blt     w2,z$sa+rhi-1
     816          ifg     z$na,>  ; if args
     817          define  dsp(pn,na,ty)
     818  <       title   pn
     819          radix   10
     820          twoseg
     821          entry   pn
     822          reloc   0
     823  z$na==na  ; save argument count
     824  z$pt==ty  ; save procedure type
     825  z$sa:   block   rhi+1>  ; allocate register save area
     826  ; dna and dnd indicate access and definition of global
     827  ; data areas.  en is external name, in is internal
     828  ; name used in t10 code, and l is block length in
     829  ; words.
     830          define  dna(en,in,l)
     831  <       extern  en
     832  in==en>
     833          define  dnd(en,in,l)
     834  <       intern  en
     835  en:     block   l
     836  in==en>
     837  ; the dw- ops define the initial value of a word
     838  ; of memory.  the first arg is address of word,
     839  ; the second is value.
     840  ; types are  a-address, c-character (right-justified
     841  ; sixbit with zero fill), i-integer, o-octal, r-real
     842  ; and s-string (left justified sixbit with blank fill).
     843  ; the second arg of dwz op is number of words to be
     844  ; initialized to zero, beginning at data address.
     845          define  dwa(da,v)
     846  <       .org    da
     847          exp     v
     848          .org>
     849          define  dwc(da,v)
     850  <       .org    da
     851          exp     v
     852          .org>
     853          define  dwi(da,v)
     854  <       .org    da
     855          dec     v
     856          .org>
     857          define  dwo(da,v)
     858  <       .org    da
     859          oct     v
     860          .org>
     861          define  dwr(da,v)
     862  <       .org    da
     863          exp     v
     864          .org>
     865          define  dws(da,v)
     866  <       .org    da
     867          sixbit  v
     868          .org>
     869          define  dwz(da,n)
     870  <       .org    da
     871          repeat  n,
     872          .org>
     873          syn     and,ban
     874          syn     andi,bani
     875          define  bfb(ra,ea)
     876  <       move    w1,ea
     877          jffo    w1,.+2
     878          movei   w2,36
     879          subi    w2,36
     880          movn    ra,w2>
     881          define  bnb(ra,ea)
     882  <       move    w1,ea
     883          setz    ra
     884          movn    w2,w1
     885          tdze    w1,w2
     886          aoja    ra,.-2>
     887          syn     setcm,bno
     888          syn     ior,bor
     889          syn     iori,bori
     890          syn     xor,bxo
     891          syn     xori,bxoi
     892          define  cal(pn,na,pl)
     893  <       movei   w1,pl
     894          movei   w2,na
     895          ifndef pn,
     896          pushj   z$sp,pn>
     897          syn     came,ceq
     898          syn     caie,ceqi
     899          syn     camge,cge
     900          syn     caige,cgei
     901          syn     camg,cgt
     902          syn     caig,cgti
     903          syn     camle,cle
     904          syn     caile,clei
     905          syn     caml,clt
     906          syn     cail,clti
     907          syn     camn,cne
     908          syn     cain,cnei
     909          syn     movm,iab
     910          syn     add,iad
     911          syn     addi,iadi
     912          define  iao(ra,ea)
     913  <       ifidn   ,
     914          ifdif   ,<
     915                  move    ra,ea
     916                  aos     ra,>>
     917          syn     movn,ico
     918          define  idi(ra,ea)
     919  <       move    w1,ra
     920          idiv    w1,ea
     921          move    ra,w1>
     922          define  idii(ra,ea)
     923  <       move    w1,ra
     924          idivi   w1,ea
     925          move    ra,w1>
     926          define  idti(ra,ea) 
     927          define  ieq(ra,ea)
     928  <       move    w1,ra
     929          movei   ra,1
     930          came    w1,ea
     931          setz    ra>
     932          define  ieqi(ra,ea)
     933  <       move    w1,ra
     934          movei   ra,1
     935          caie    w1,ea
     936          setz    ra>
     937          define  ige(ra,ea)
     938  <       move    w1,ra
     939          movei   ra,1
     940          camge   w1,ea
     941          setz    ra>
     942          define  igei(ra,ea)
     943  <       move    w1,ra
     944          movei   ra,1
     945          caige   w1,ea
     946          setz    ra>
     947          define  igt(ra,ea)
     948  <       move    w1,ra
     949          movei   ra,1
     950          camg    w1,ea
     951          setz    ra>
     952          define  igti(ra,ea)
     953  <       move    w1,ra
     954          movei   ra,1
     955          caig    w1,ea
     956          setz    ra>
     957          define  ile(ra,ea)
     958  <       move    w1,ra
     959          movei   ra,1
     960          camle   w1,ea
     961          setz    ra>
     962          define  ilei(ra,ea)
     963  <       move    w1,ra
     964          movei   ra,1
     965          caile   w1,ea
     966          setz    ra>
     967          define  ilt(ra,ea)
     968  <       move    w1,ra
     969          movei   ra,1
     970          caml    w1,ea
     971          setz    ra>
     972          define  ilti(ra,ea)
     973  <       move    w1,ra
     974          movei   ra,1
     975          cail    w1,ea
     976          setz    ra>
     977          define  imo(ra,ea)
     978  <       move    w1,ra
     979          idiv    w1,ea
     980          move    ra,w2>
     981          define  imoi(ra,ea)
     982  <       move    w1,ra
     983          idivi   w1,ea
     984          move    ra,w2>
     985          define  imti(ra,ea) 
     986          syn     imul,imu
     987          syn     imuli,imui
     988          define  ine(ra,ea)
     989  <       move    w1,ra
     990          movei   ra,1
     991          camn    w1,ea
     992          setz    ra>
     993          define  inei(ra,ea)
     994  <       move    w1,ra
     995          movei   ra,1
     996          cain    w1,ea
     997          setz    ra>
     998          define  isi(ra,ea)
     999  <       move    w1,ea
    1000          movem   ra,ra
    1001          jumpe   w1,.+2
    1002          moven   ra,ea>
    1003          define  iso(ra,ea)
    1004  <       ifidn   ,
    1005          ifdif   ,<
    1006                  move    ra,ea
    1007                  sos     ra,>>
    1008          syn     sub,isu
    1009          syn     subi,isui
    1010          syn     jumpe,jeq
    1011          syn     jumpge,jge
    1012          syn     jumpg,jgt
    1013          syn     jumple,jle
    1014          syn     jumpl,jlt
    1015          syn     jump,jmn
    1016          syn     jumpa,jmp
    1017          syn     jumpn,jne
    1018          define  lab(l) 
    1019          syn     movei,lda
    1020          define  ldf(ra,ea) 
    1021          syn     hlrz,ldl
    1022          syn     hlrzi,ldli
    1023          syn     hrrz,ldr
    1024          syn     hrrzi,ldri
    1025          syn     move,ldw
    1026          syn     movei,ldwi
    1027          define  lpr(ra,ea,c1,c2) 
    1028          define  mvw(ra,ea,n)
    1029  <       hrl     w1,ra
    1030          hrri    w1,ea
    1031          movei   w2,ea
    1032          addi    w2,n-1
    1033          blt     w1,w2>
    1034          syn     movm,rab
    1035          syn     fad,rad
    1036          syn     movn,rco
    1037          syn     fdvr,rdi
    1038          syn     ieq,req
    1039          define  ret(pn)
    1040  <       ife     z$pt-z$pt.f,<
    1041          hrr     z$sp,r1
    1042          hrlzi   z$sp,z$sa
    1043          blt     z$sp,rhi>
    1044          ifn     z$pt-z$pt.f,<
    1045          hrlzi   z$sp,z$sa
    1046          blt     z$sp,rhi>
    1047          popj    z$sp,>
    1048          syn     ige,rge
    1049          syn     igt,rgt
    1050          syn     ile,rle
    1051          syn     ilt,rlt
    1052          define  rmo(ra,ea)
    1053  ;       rmo code is (incorrect) copy of imo code
    1054  <       move    w1,ra
    1055          idiv    w1,ea
    1056          move    ra,w2>
    1057          syn     fmp,rmu
    1058          syn     ine,rne
    1059          syn     isi,rsi
    1060          syn     fsb,rsu
    1061          define  spr(ra,ea,c1,c2) 
    1062          define  stf(ra,ea) 
    1063          syn     hrlm,stl
    1064          syn     hrrm,str
    1065          syn     movem,stw
    1066          define  zebi(ra,n)
    1067  <       movei   w1,1(ra)
    1068          hrl     w1,ra
    1069          setzm   ,0(ra)
    1070          blt     w1,n(ra)>
    1071          syn     setzm,zew
    1072          end
    1073 */
    1074 ..docnote
« May 2022 »
Su Mo Tu We Th Fr Sa
1 2 3 4 5 6 7
8 9 10 11 12 13 14
15 16 17 18 19 20 21
22 23 24 25 26 27 28
29 30 31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: