Personal tools
You are here: Home Projects SETL LITTLE Source code GEN: Parse and semantic analysis phase.
Document Actions

GEN: Parse and semantic analysis phase.

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

GEN: Parse and semantic analysis phase.

       1 .=member  intro
       2 $     !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
       3 $    the above line contains, in order of ascii codes, the 56
       4 $    characters of the little language, starting in column 7.
       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                $$$$$$$$$  $$$$$$$$$$  $$      $$
      32
      33
      34     this software is part of the little programming system.
      35              address queries and comments to
      36
      37                       little project
      38               department of computer science
      39                    new york university
      40         courant institute of mathematical sciences
      41                     251 mercer street
      42                    new york,  ny  10012
      43
      44     this is the second phase of the little compiler.  it performs
      45     the parse and semantic analysis, and is known as 'gen'.
      46
      47     the principal authors of the little compiler are
      48     robert abes, edith deak, richard kenner, david shields
      49     and aaron stein.
      50
      51
      52
      53 */
      54
      55
      56
      57
       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
       1 .=member  modform
       2 $    every change is to include a description after the card mods.2 in
       3 $    the mods deck below.
       4 $    mod description is to contain name starting in column 7, author
       5 $    name starting in column 17, date starting in column 37, and
       6 $    new level established starting in column 57, as follows.
       7 $       1         2         3         4         5         6
       8 $    7890123456789012345678901234567890123456789012345678901234567
       9 $    modname   author name         10 february 1976    level 76041
      10 $
      11 $    the 'level' is the julian date of the change and the macro
      12 $    'compilerlevel' should be changed whenever level is changed, so
      13 $    that level printed on listing (cf routine genini) will be correct.
      14 $    the title is followed by blank line (with $ in column 2), then
      15 $    description of purpose of change, and finally list of code
      16 $    affected, in following form.
      17 $    decks affected -  list of decks(routines) affected by this mod.
      18
      19
      20
       1 .=member  mods
       2 $ - - - all changes are to include self-description after mods.2
rbko   1$
rbko   2$     rbko      r. kenner           6 june 1982         level 82158
rbko   3$
rbko   4$     print three blanks instead of four in -lstlin- so that tabs imbedd
rbko   5$     in lines being listed come out correctly.
rbko   6$
rbko   7$     decks affected: lstlin
rbko   8$
utsc   1
utsc   2 $    utsc      d. shields          18-dec-81           level 81352
utsc   3 $
utsc   4 $    extend ebcasc option so ebcasc=2 folds input to lower case.
utsc   5 $    deck affected - cnvcon.
utsc   6
utsa   1
utsa   2 $    utsa      d. shields          29-nov-81           level 81333
utsa   3 $
utsa   4 $    support s47: amdahl uts (universal timesharing system).
utsa   5 $    this implementation runs on s37 architecture using an operating
utsa   6 $    system very close to unix (v7), and uses the ascii character set.
utsa   7 $
utsa   8 $    1.  add option 'ebcasc=0/1' to s37 such that ebcasc=1 causes
utsa   9 $        character string to be converted from ebcdic to ascii.
utsa  10 $        this is needed for uts bootstrap from s37, and would be needed
utsa  11 $        to bootstrap nyu ada/ed to s37.
utsa  12 $    2.  change layout of strings for s37 so same structure for s32,
utsa  13 $        s37 and s47 (.sl.=16, .so.=16).
utsa  14 $    deck added - ebcasc (s37)
utsa  15
eaa    1
eaa    2 $    eaa       d. shields          31-aug-81           level 81243
eaa    3 $
eaa    4 $    support new target machine s20 (s10 with extended addressing)
eaa    5 $    by recognizing 'tm=20'. this is s10 except pointer size is 30.
eaa    6 $    decks affected - macros, genini
eaa    7
ldse   1
ldse   2 $    ldse      d. shields          24-sep-80           level 80268
ldse   3 $
ldse   4 $    add program parameter 'expire=0/366' such that if expire has
ldse   5 $    non-zero value, then program is to expire (cease execution)
ldse   6 $    the given number of days after compilation.  expiration check
ldse   7 $    done by ltllib procedure 'ltlced', parameterized as 'proc_expire'.
ldse   8 $    decks affected - macros, start, genini, gensub.
ldse   9
ldsd   1
ldsd   2 $    ldsd      d. shields          30-jul-80           level 80212
ldsd   3 $
ldsd   4 $    1.  do dim offline for s32 to avoid asm problem.
ldsd   5 $        this adds new library function 'mth$dim' for s32.
ldsd   6 $    2.  do aint and amod offline for s32 to avoid problems
ldsd   7 $        in unsupported rtr and rmo t32 operations.
ldsd   8 $        this adds new library functions 'mth$aint' and
ldsd   9 $        'mth$amod' for s32.
ldsd  10 $    3.  identify s32 dialect in listing header.
ldsd  11 $    4.  increase tlistmax so can compile s32 asm.
ldsd  12 $    5.  check for invalid or out-of-range real constant.
ldsd  13 $    decks affected - macros, start, genini, cnvcon, ermes.
ldsd  14
ldsc   1
ldsc   2 $    ldsc      d. shields          21-jul-80           level 80203
ldsc   3 $
ldsc   4 $    1.  fix error (fr139) that caused problems if lcp=0 specified.
ldsc   5 $    2.  avoid needless copy to terminal.
ldsc   6 $    3.  enable pt parse trace for unix checkout.
ldsc   7 $    decks affected - macros, genini, genexit.
ldsc   8
ldsb   1
ldsb   2 $    ldsb      d. shields          10-jul-80           level 80192
ldsb   3 $
ldsb   4 $    1.  fix problem (fr135) in setting of termination code.
ldsb   5 $        now issue code 0 if no warnings or errors, code 4 if warnings
ldsb   6 $        and no errors, code 8 if any errors detected.
ldsb   7 $    2.  do not generate 'no errors detected' message.
ldsb   8 $    4.  add conditional symbol -unix- for the unix operating system.
ldsb   9 $        use iset=unix to obtain unix variant.
ldsb  10 $        want listing terse, make lcp=0 and lcs=0 the defaults.
ldsb  11 $        for initial checkout, delete special env code (mova, etc.).
ldsb  12 $
ldsb  13 $    decks affected - macros, genini, genexit.
ldsb  14
ldsa   1
ldsa   2 $    ldsa      d. shields          25-mar-80            level 80085
ldsa   3 $
ldsa   4 $    add option 'rep=0/pg' to permit generation of 'report' file on
ldsa   5 $    unit 6. each line on the file is in a format acceptable to
ldsa   6 $    most macro assemblers - columns 1-8 are blank, column 9
ldsa   7 $    contains a one character opcode and the operands, separated
ldsa   8 $    by commas, begin in column 17. opcodes and operands are
ldsa   9 $     c  caller_name,called_name,number_args
ldsa  10 $     g  var_name,size,dimension,nameset_name,address_offset
ldsa  11 $     n  nameset_name,nameset_length
ldsa  12 $     p  proc_name,proc_type,proc_args
ldsa  13 $        (type is 1 for subr, 2 for fnct, 3 for prog)
ldsa  14 $    the rep= parameter string may contain letters c, g or p.
ldsa  15 $    if -g- appears in rep parameter string, both -n- and -g- opcodes
ldsa  16 $    are written.
ldsa  17 $    this feature replaces (and extends) the previous pcr feature.
ldsa  18 $    text conditioned by -rep-.
ldsa  19 $    decks affected - macros, start, gensub, sortvars, emcall,
ldsa  20 $        genexit, putrep (new).
ldsa  21
dsz    1
dsz    2 $    dsz       d. shields          29-feb-80           level 80060
dsz    3 $
dsz    4 $    report error if function name is unsized in function definition.
dsz    5 $    deck affected - closer.
dsz    6
dsy    1
dsy    2 $    dsy       d. shields          29-jan-80           level 80029
dsy    3 $
dsy    4 $    fix error (fr2.3.129) that caused problems if function call
dsy    5 $    and unary operator hashed to same location in basic block.
dsy    6 $    deck affected - emcall.
dsy    7
dsx    1
dsx    2 $    dsx       d. shields          10-jan-80           level 80010
dsx    3 $
dsx    4 $    1.  increase hamax from 787 to 937. this requires corresponding
dsx    5 $        change to asm, as ha written to voa file.
dsx    6 $    2.  add (experimental) option pcr (procedure call report) such
dsx    7 $        that pcr=1 causes creation of report on unit 6. each call of
dsx    8 $        subroutine or function is indicated by line with name of
dsx    9 $        caller, a blank and name of procedure called.
dsx   10 $        use conditional assembly option pcr for this.
dsx   11 $    decks affected - macros, start, genini, emcall.
dsx   12
dsw    1
dsw    2 $    dsw       d. shields          14-dec-79           level 79348
dsw    3 $
dsw    4 $    extend maximum permitted dimension for s10, s32 and s37 up
dsw    5 $    to 2**n-1 with n=17, 30 and 22, respectively. this involves
dsw    6 $    change to voa, nl, mba and xha, so that voa file format changed.
dsw    7 $    decks affected - macros, start.
dsw    8
dsv    1
dsv    2 $    dsv       d. shields          19-nov-79           level 79323
dsv    3 $
dsv    4 $    1.  rewind token file and voa file for s66 only.
dsv    5 $    2.  use getapp (new lib procedure provided by mod dsc) to
dsv    6 $        obtain and list actual parameter string specified by user.
dsv    7 $    3.  delete code to read term= parameter and possibly open
dsv    8 $        terminal file, as this now done by lib (mod dsc).
dsv    9 $    decks affected - macros, genini.
dsv   10
dsu    1
dsu    2 $    dsu       d. shields          10-sep-79           level 79253
dsu    3 $
dsu    4 $    fix bug that caused pdir option to work only if lcr option
dsu    5 $    selected (fr2.3.120).
dsu    6 $    deck affected - genini.
dsu    7
mgfc   1
mgfc   2 $    mgfc      m.g. ford           15-aug-79           level 79227
mgfc   3 $
mgfc   4 $    issue standard warning and error characters for s10.
mgfc   5 $    decks affected - macros, gtoflo, ermet, ermes, closer, genexit.
mgfc   6
mgfb   1
mgfb   2 $    mgfb      m.g. ford           05-jul-79           level 79186
mgfb   3 $
mgfb   4 $    revise s10 to use 9-bit ascii.  this mod affects s10 version only.
mgfb   5 $    decks affected - macros, start, genini
mgfb   6
dst    1
dst    2 $    dst       d. shields          29 mar 79           level 79088
dst    3 $
dst    4 $    1.  fix errors in mbchain, vbegl fields for s10, s32 (fr2.3.100).
dst    5 $    2.  report error if operand to arithmetic comparison multi-word.
dst    6 $    decks affected - macros, start, ermes, emit2, sortvars.
dst    7
dss    1
dss    2 $    dss       d. shields          30 jan 79           level 79030
dss    3 $              r. kenner
dss    4 $
dss    5 $    1.  make data structures for -monitor- features more
dss    6 $        machine-independent (fr2.3.75).
dss    7 $    2.  add -isuse- calls in genioit (fr2.3.78).
dss    8 $    3.  move warning message processing for overlong temporaries
dss    9 $        from -blkend- to -ermes-.
dss   10 $    4.  add program parameter  'cis=0/n' to check index size.  if
dss   11 $        option value is nonzero, then any instance of a(e) where size
dss   12 $        of e is greater than option value is reported as warning.
dss   13 $        the default value n is chosen according to pointer size.
dss   14 $        this option added to assist in setl debugging.
dss   15 $    5.  adjust some field definitions for s32.
dss   16 $    decks affected - start, genini, blkend, ermes, genioit,
dss   17 $        emit2, emass, gendebug.
dss   18
dsr    1
dsr    2 $    dsr       d. shields          27 dec 78           level 78361
dsr    3 $
dsr    4 $    1.  fix error (fr2.3.72) in unpacking tokens in -parse- if
dsr    5 $        -unpk_env- not enabled.
dsr    6 $    2.  fix error (fr2.3.74) in arith in that comparisons
dsr    7 $        of multi-word items with constants wrongly folded by
dsr    8 $        arith in some cases.
dsr    9 $    3.  expand functions aint, amod, float, ifix and int in-line
dsr   10 $        for s10 and s32.
dsr   11 $    decks affected - genini, parse, arith.
dsr   12
dsq    1
dsq    2 $    dsq       d. shields          18 dec 78           level 78352
dsq    3 $
dsq    4 $    correct error (fr2.3.66) reported in -gencfi- in that
dsq    5 $    call to -gendfi- did not specify argument zero.
dsq    6 $    deck affected - gencfi
dsq    7
meal   1
meal   2 $    dsp       d. shields          27 nov 78           level 78331
meal   3 $
meal   4 $    add program option 'meal=1/0' (m-onitor e-ntry a-rgument l-ist)
meal   5 $    such that zero value causes monitor procedure entry code not
meal   6 $    to include print of argument values.  this effected by adding
meal   7 $    new global vlariable -trentrargs- which must be nonzero if gensiz
meal   8 $    is to emit trace code to print argument values.
meal   9 $    this feature requested by setl group.
meal  10 $    decks affected - start, genini, gensiz.
meal  11
vax    1
vax    2 $    vax       d. shields          21 nov  78          level 78325
vax    3 $              r. kenner
vax    4 $
vax    5 $    add configuration values for s32: dec vax-11.
vax    6 $    decks affected - macros, start, genini, parse, squeeze, sortvars.
vax    7
dso    1
dso    2 $    dso       d. shields          25 sep 78           level 78268
dso    3 $
dso    4 $    1.  add code for resident s10 compiler.
dso    5 $    2.  add tm=40 (prime 400) target machine.
dso    6 $    decks affected - macros, start, genini.
dso    7
rbkn   1
rbkn   2 $    rbkn      r. kenner           19 jun 78           level 78170
rbkn   3 $
rbkn   4 $    reported bug - .len. =  causes compilation error if option
rbkn   5 $    help selected.
rbkn   6 $    fix - missing data entry in trstorr.
rbkn   7 $    deck affected - trstorr.
rbkn   8
       3
       4 $    chars     d. shields          30 may 78           level 78150
       5 $
       6 $    include deck chars to describe character set to assist in
       7 $    correct translation of source text for new machines.
       8 $    correct error in use of cdc character set so that apostrophe
       9 $    represented by cdc display code 3b'70' (up arrow).
      10 $    decks affected - all (source resequenced).
      11
      12
      13 $    dsn       d. shields          15 may 78           level 78135
      14 $
      15 $    1.  correct target machine parameters for s10.
      16 $    2.  fix error message for negative dimension.
      17 $    3.  list current procedure name if abnormal termination.
      18 $    decks affected - genini, gendim, genexit.
      19
      20
      21 $    rbkm      r. kenner           01 mar 78            level 78060
      22 $              d. shields
      23 $
      24 $    1.  correct error in haprobe macro.
      25 $    2.  correct -fidtab- entry for .sne.
      26 $    3.  fix bug if .ch. and .f. in same statement.
      27 $    4.  fix listing control.
      28 $    5.  fix sizing of r-tokens in cnvcon.
      29 $    6.  correct field definitions for s37.
      30 $    decks affected - start, parse, ptdata, cnvcon, nextok, arith.
      31
      32
      33 $    dsm       d. shields          04 jan 78           level 78004
      34 $
      35 $    give error message if size of zero specified.
      36 $    decks affected - gensiz, ermes.
      37
      38
      39 $    rbkl      r. kenner           29 dec 77           level 77363
      40 $
      41 $    1.  fix errors in s37 conditional text.
      42 $    2.  install s-type tokens.  see lex mod rbkg.
      43 $    3.  change 'subr start' to 'prog start' on s37 since phases
      44 $        are not part of one large overlay.
      45 $    4.  fix bug in flow trace which causes if-true and if-false not
      46 $        to be paired at run-time.
      47 $    5.  have store trace call different routine depending on how many
      48 $        parameters it must pass.
      49 $    6.  have size of internally generated variables for -do- be mws if
      50 $        the value being assigned to them has size greater than mps.
      51 $    7.  fix dimension of -fidtab- in -arith-.
      52 $    8.  fix bug in -marith- folding of .not. which caused constants
      53 $        of size zero to be generated.
      54 $    9.  fix error which caused -setq- to loop printing error messages
      55 $        if it detected an item of size zero.
      56 $    10. do not have -ha- dump attempt to print -names- array for strin
      57 $    11. test for -arglist- overflow in -gengosl-.
      58 $    12. -syntab- was replaced because at least one -pt- entry differs
      59 $        from what assembly of -ltlgrmr- should be.
      60 $    decks affected - macros, start, genini, ptdata, gtoflo, nextok,
      61 $                     cnvcon, ermes, arith, marith, gendo, gengosl,
      62 $                     gensiz, getdovar, sortvars, trflowr, trstorr,
      63 $                     hadump, voadump, genexit
      64
      65
      66 $    dsl       d. shields          08 dec 77           level 77342
      67 $
      68 $    1.  assign correct (integer) arithmetic mode to -idim-.
      69 $    2.  fix error in flow trace for compound if with no else part.
      70 $    3.  do not collect function names for assert statement list.
      71 $    4.  compile no code for assert with nonzero constant expression.
      72 $    5.  make operator precedence levels consistent with guide.
      73 $    6.  fix error so truncate if .pad. string longer than desired
      74 $        length.
      75 $    7.  compute size of .not. of constant correctly.
      76 $    decks affected - start, trflowr, gensert, genpad, marith.
      77
      78
      79 $    dsk       d. shields          08 nov 77           level 77312
      80 $
      81 $    detect zero length .e. and .f. extracts, returning zero on
      82 $    extraction, and treating as no-op on assignment.
      83 $    decks affected - genextr, emass.
      84
      85
      86 $    dsj       d. shields          03 nov 77           level 77307
      87 $
      88 $    1.  add conditional option pack_env, and modify cnvcon to call
      89 $        pack$li directly if environment pack procedure available.
      90 $    2.  reported bug - unable to compile real function invocations
      91 $        with expression arguments.
      92 $        cause - emcall incorrectly setting amode (bug uncovered by mod
      93 $        rbkj).
      94 $    3.  give better message for mixed-mode expressions.
      95 $    4.  delete code in emit2 made dead by mod rbkj.
      96 $    decks affected - macros, cnvcon, ermes, emcall, emit2.
      97
      98
      99 $    rbkk      r. kenner           28 oct 77           level 77301
     100 $
     101 $    this mod is needed for lex mod rbkf to keep the line counts
     102 $    correct.
     103 $    deck affected - nextok
     104
     105
     106 $    rbkj      r. kenner           11 oct 77           level 77284
     107 $
     108 $    this mod is an mostly an internal cleanup of gen.  the
     109 $    major areas of change are listed below.
     110 $    1.  conditional text has been added for s10.
     111 $    2.  field definitions have changed, especially for s37.
     112 $    3.  the parser has been speed up by putting in a bit
     113 $        more special cases and by slightly recoding certain
     114 $        statements and reordering some tests.
     115 $    4.  the handling of -end- statements has been changed
     116 $        in the case of errors.  if the next token does not
     117 $        match any opener, the -end- is ignored and only if
     118 $        the next token matches will it be processed.  if the
     119 $        next few tokens exactly match an opener but not the last
     120 $        opener, the previous ones will be closed with an error
     121 $        message.  this sould reduce the number of 'runaway' error
     122 $        cases.
     123 $    5.  the scan for next semicolon in the case of error has been
     124 $        fine-tuned to also check for a 'then' in the case of an 'if'.
     125 $    6.  the text, format, and content of the syntactic error
     126 $        messages have been redone and the error message numbers have
     127 $        been re-ordered.
     128 $    7.  a bug which caused gen to loop if the current routine was a
     129 $        function and the function name was unsized has been fixed.
     130 $    8.  the drop bits for variables are now set when it is the last
     131 $        use before a (simple) assignment even if it is not the last
     132 $        use in the basic block.  the same goes for a variable or
     133 $        constant referenced in a subroutine or function call.
     134 $    9.  the usage count for constants are not incremented in cases
     135 $        where asm would normally not use the values (like .f. indices)
     136 $    10. gen will ensure that enough space exists in the machine
     137 $        block for element zero of an array. (370 asm and maybe some
     138 $        others in the future need this).
     139 $    11. namesets are now openers and entered in the -csa-.  this
     140 $        allows other openers in namesets and allows nameset statements
     141 $        to be nested.
     142 $    12. detection of when something is a function has been redone.
     143 $        something is now concidered a function only when it is not
     144 $        dimensioned, has never been used as a simple variable, and
     145 $        does not have the same name as a built-in function.  error
     146 $        messages are issued in the cases in which something which was
     147 $        probably erroneous would have previously been treated as a
     148 $        function.  also, a global variable can be treated as a functio
     149 $        so that functions which are used a lot can be sized in start
     150 $        and need not be sized in every other routine which calls it.
     151 $
     152 $    decks affected - (most)   source has been resequenced.
     153 $    decks added - findcsa, closer, pfind (also some routines have been
     154 $                                         put in their own decks)
     155 $    decks deleted - findloop, comptok, pushr
     156
     157
     158 $    dsi       d. shields          02 aug 77           level 77214.
     159 $
     160 $    this mod fixes a few minor problems and installs a new parser.
     161 $
     162 $    1.  reported bug - arithmetic mode not set for real temporaries.
     163 $        fix - set type field of temporaries.
     164 $        (this only caused problems on s37 implementation.)
     165 $    2.  reported bug - real constants incorrectly folded on s16.
     166 $        fix - gen will no longer attempt to fold real constant
     167 $        expressions if the host and target machines differ.
     168 $    3.  reported bug - notrace monitor directive not working correctly
     169 $        fix - error in grammar in setting of codes to pass to gentrace
     170 $        has been fixed.
     171 $
     172 $    this mod also modifies the parse procedure -parse- to use
     173 $    the parsing strategy supported by the program -syn-.  the
     174 $    parse now detects expressions which consist of a single name
     175 $    or constant more efficiently, and also does a more efficient
     176 $    job parsing terms in expressions.
     177 $
     178 $    the new procedure lstlin is used to list input lines.
     179 $
     180 $    decks affected - parse, nextok, ermet, arith, blkend,
     181 $        lstlin (new), and procedures which formerly called nextok to
     182 $        list input lines.
     183
     184
     185 $    dsh       d. shields          20 may 77           level 77140.
     186 $
     187 $    1.  support unary plus.
     188 $    2.  permit use of 'err' as synonym for 'error' in filestat query.
     189 $    3.  do not print trailer strings (io, monitor) in parameter
     190 $        list as user cannot alter them.
     191 $    4.  make size of integer multiply ws on s16.
     192 $    decks affected - start, genini, parse, arith, marith, emit2.
     193
     194
     195 $    rbki      r. kenner           30 apr 77           level 77120
     196 $
     197 $    fix a bug in the handling of 'monitor' statements which caused
     198 $    all such statements which did not have an explicit 'limit'
     199 $    paramater to set the monitor line limit to infinite.
     200 $    deck affected - gendebug
     201
     202
     203 $    dsg       d. shields          22 apr 77           level 77112.
     204 $
     205 $    1.  change -cursor- to -column- in filestat inquiry, so now use
     206 $        filestat(fileexpr, column) to get current column.
     207 $    2.  avoid reference to zero-th element of littab in nextok.
     208 $    decks affected - parse, nextok.
     209
     210
     211 $    dsf       d. shields          14 mar 77           level 77073.
     212 $
     213 $    1.  avoid popping csa if error seen.
     214 $    2.  declare negative constants to be 'safe' and give them size
     215 $        word size.
     216 $    decks affected - inscon, ermet, arith.
     217
     218
     219 $    dse       d. shields              04 february 1977    level 77035.
     220 $
     221 $    1.  fix error in conversion of real constants in cnvcon.
     222 $    2.  fix computation of subtitle in gensub so strings aligned
     223 $        on word boundaries.
     224 $    3.  move misplaced test in gensize that caused problems in trace
     225 $        stores list processing in gensize.
     226 $    4.  correct gencall and emcall to manipulate arglist pointer
     227 $        correctly, so that unsized variable in argument list does
     228 $    5.  remove duplicate data statement for prhd in monitor setup.
     229 $        not cause problems.
     230 $    6.  correct calculation of size of string concatenation.
     231 $    decks affected - cnvcon, gencall, gensize, gensub, emcall, emit2.
     232
     233
     234 $    dsd       d. shields          7 january 77        level 77007.
     235 $
     236 $    convert to use new library and support only new language level.
     237 $
     238 $    1.  drop support of 'old' tokens: h, z, d, l and octal b.
     239 $    2.  use 'monitor' instead of 'debug'.
     240 $    3.  drop support of multiword arithmetic.
     241 $        (new definition and implementation due soon.)
     242 $    4.  use -getipp- and -getspp- to get program parameters.
     243 $    5.  on s66, place certain arrays in blank common to
     244 $        reduce size of absolute overlay.
     245
     246 $    the source has been resequenced.
     247 $    decks affected - all.
     248
     249 $    dsc       d. shields          15 november 76      level 76320.
     250 $    1.  support new language level, indicated by 'lev' compiler
     251 $        option.  the new level renames math library functions for
     252 $        s66, does not support .c., and supports .pad. operator.
     253 $        the new level also sorts namesets so storage allocated in
     254 $        order of declaration, not in 'reverse' order of old level.
     255 $    2.  add '.pad.' operator, of form 'str .pad. int' where -str-
     256 $        is a character string constant and -int- is integer constant.
     257 $        the result is the string padded to right with blanks to have
     258 $        length -int-.
     259 $    3.  fix debugging package reported by brooklyn college, as a
     260 $        test was out of place in gensiz.
     261 $    4.  support main program unit, or -prog- statement.
     262 $    5.  do not require 'return' at end of procedure, and
     263 $        compile 'end subr' or 'end fnct' statement into 'return'.
     264 $        a return from main program terminates execution.
     265 $    6.  support character string comparison operators .seq. and .sne.
     266 $    decks affected - most (source has been resequenced).
     267
     268
     269 $    dsb       d. shields          6 october 1976      level 76280.
     270 $
     271 $    1.  enable 'ncfopt' by default.
     272 $    2.  eliminate references to file name strings and buffer lengths
     273 $        since files now represented by unit numbers.
     274 $    3.  add 'read' and 'write' literals and process binary io.
     275 $    4.  revise processing of io.
     276 $    decks affected - start, parse, io routines.
     277
     278
     279 $    rbkh      r. kenner           10 august 76        level 76223
     280 $
     281 $    1.  remove input format -f- from list of i/o routine because
     282 $        it is the same as input format -e-.
     283 $    2.  add a field  to the -voa- to count the number of uses of
     284 $        a variable or constant within a routine.
     285 $    3.  set drop bits for variables and constants in addition to
     286 $        temporaries.
     287 $    4.  for all machines other than s66, have -cont do- compile
     288 $        as a -go to- test label rather than as an increment
     289 $        and test at the site of the -cont-.
     290 $    5.  special case -if (e) cont- and -if (e) quit- so as not
     291 $        to end a basic block and to use the -ifgo- operation.
     292 $        this is not done in the case of a -cont do- on s66.
     293 $    6.  defer allocation of address for variables until end of
     294 $        a routine and sort each nameset in order to have the smaller
     295 $        variables at the start of the nameset.  this aids in base
     296 $        register allocation on s37 and will help on machines which
     297 $        use paged virtual storage.
     298 $    7.  change the name of the default nameset to have a dollar sign
     299 $        in column one followed by the rest of the routine name instead
     300 $        of using the routine name.  this change is needed for machines
     301 $        (like s37 and s11) for which a common block and routine may
     302 $        not have the same name.
     303 $    8.  set up a mechanism to re-use internal variables defined for
     304 $        -do- statements in the same manner as is done for itterators
     305 $        in i/o statements.
     306 $    9.  fix bug in freeing internal variables in i/o statements.
     307 $    10. dont end basic block on some i/o calls.
     308 $    11. give error message on assignment to function parameter.
     309 $    12. give error message on indexed assignment to variable that
     310 $        is not an array.  (no -dims- statement for it)
     311 $    13. change text of some more error messages.
     312 $    14. add -seblk- field to -voa- to indicate which subroutine
     313 $        calls end a basic block.
     314 $    15. add -bytaln- field to -voa- to indicate which extractions
     315 $        or assignments are done on character-aligned data.
     316 $    16. install new -voa- field layout for s37.
     317 $    17. make dimension of some arrays dependent on machine and
     318 $        install dimensions for s37.
     319 $    18. remove code in -emit2- to bypass common multi-word indexed
     320 $        loads on s66 because bug fixed in s66 -asm-.
     321
     322 $    rbkg      r. kenner           30 july 76          level 76212
     323 $
     324 $    fix miscellaneous bugs detected upon s37 bootstrap of
     325 $    last level.  also, fix two bugs in parsing new i/o.
     326
     327 $    rbkf      r. kenner           22 july 76          level 76204
     328 $
     329 $    1.  fix reported bugs.
     330 $        1.  'notrace'/'nocheck' do not work - error in grammar.
     331 $        2.  'debug entry' is not recognized as valid due to error in
     332 $            -keycode- call.
     333 $        3.  some error messages do not appear in terminal file.
     334 $        4.  bad formatting of listing if 'pdir' set.
     335 $        5.  last few token list does not intialize correctly.
     336 $        6.  trace or check statements for global variables occuring
     337 $            after the -size- statements for those variables, do not
     338 $            work correctly.
     339 $    2.  change iotype=storage  to  iotype=string
     340 $    decks affected - parse, genend, gensub, squeeze, geniost, pdsort
     341 $                     gentrace
     342
     343 $    rbke      r. kenner           16 july 76          level 76198
     344 $              d. shields
     345 $
     346 $    1.  insert blank lines around error notices to make them more
     347 $        noticable.
     348 $    2.  have 'possibly illnested loop..' message be an error rather
     349 $        than a warning and change the text.
     350 $    3.  correctly process 'voa=0'.
     351 $    4.  change handling of constant expression to just check if
     352 $        the final result is a safe constant (i.e., 'i-i+1' is a safe
     353 $        constant). remove -cexpress- and -cexperr- and change grammar.
     354 $    5.  have -genexit- recieve its parameter globally to avoid problem
     355 $        in s37 when overlaying compiler.
     356 $    6.  allow 'term' option to have error messages written to a
     357 $        separate file for use in some interactive systems.
     358 $    7.  install code to parse and process new 'little i/o'.
     359 $    8.  miscellaneous code changes.
     360
     361
     362 $    rbkd      r. kenner           09 july 76          level 76191
     363 $
     364 $    1.  allow .len. as abbreviation for '.f. 1, .sl.,'.
     365 $    2.  the -quit- and -cont- statements are no longer restricted
     366 $        to the innermost loop; the tokens following the quit and
     367 $        cont determine the loop.
     368 $    3.  unary operations on constants are done at compile time, if
     369 $        possible.
     370 $    4.  continue work on error handling.
     371 $    5.  require constant expressions use only 'safe' constants.
     372 $    6.  value in data statement must be constant, but not necessarily
     373 $        constant expression.
     374 $    7.  begin implementation of revised (yet again) little io.  drop
     375 $        support of io as defined in little newsletter 34.
     376 $    8.  the -debug- statement is used for run time control of
     377 $        debug package.  the statement consists of -debug- followed
     378 $        by a list of parameters, separated by commas.  parameters are
     379 $        as follows:
     380 $            limit = expr      set line limit to expr.
     381 $            nolimit           suppress debug line limit check.
     382 $            flow (noflow)     enable (disable) print for -flow-.
     383 $            stores (nostores) enable (disable) print for -stores-.
     384 $            entry (noentry)   enable (disable) print for -entry-.
     385 $            byte (nobyte)     include (suppress) print of value as
     386 $                              byte constant.
     387 $
     388 $        default is  'debug flow, stores, entry, nobyte;' .
     389 $        the debug line limit is initially 9/10 of print line limit.
     390 $    9.  implement new rules for scope of debugging statements.
     391 $   10.  support 'autotitle' option in list directive which uses
     392 $   11.  have first line of proceedure list as line 1 by defering
     393 $        the listing of a card until the next is read.
     394 $        first line of each procedure as subtitle text.
     395
     396
     397 $    rbkc      r. kenner         02 july 76            level 76184
     398 $              d. shields
     399 $
     400 $    1.  improve error handling by rewording some error messages
     401 $        and attempting to avoid the 'runaway' errors that occured
     402 $        previously.
     403 $    2.  add a field -hainuse- to the -ha- to avoid multi-word
     404 $        comparisons on s37.
     405 $    3.  rename -labintern- to -namintern- and set for internal
     406 $        variables also instead of just labels.
     407 $    4.  remove old format octal and bit constants and convert
     408 $        to new format byte constants.
     409 $    5.  insert conditional text -oldtoks- to continue support
     410 $        of old token types.  this is set on for s66 because of
     411 $        the large number of existing programs which would have to
     412 $        be converted, but is set off for s37.
     413 $    6.  generate labels of the form 'l(n)' instead of 'l.nnn'
     414 $        for subscripted labels.
     415 $    7.  if .cc. is done on constants, do at compile time.
     416 $    8.  allow '!!' in place of '.cc.' (as in pl/1)
     417 $    9.  implement .voapart. to give dump of just voa, xarg, and csa.
     418 $    10. increase dimensions of -xarg- and -lablist-.
     419 $    11. miscellaneous changes to code style and come size statments
     420 $        to improve (hopefully) efficiency and improve readability
     421 $        and machine-independance.
     422
     423
     424 $    rbkb      r. kenner           28 jun 76           level 76180.
     425 $              d. shields
     426 $
     427 $    1.  modify identification of builtin functions to allow module
     428 $        names which differ from names in source.
     429 $        select functions to be done inline accodring to target
     430 $        machine.
     431 $    2.  support paged, titled listing and new directives for
     432 $        list control.
     433 $    3.  eliminate 'version number' approach to identifying voa file
     434 $        and use only julian date of last change to voa file structure.
     435 $    4.  require label subscripts l to be in range 0 <= l <= 999.
     436 $    5.  extend lablistlen from 300 to 400.
     437 $    6.  support option 'pdir' which produces list of procedures sorted
     438 $        by name and with page number of first line if input listing on
     439 $        when first line seen.
     440 $        implementation: raise cross reference option and write page
     441 $        number in ref entry.  at end of input, read ref file and sort
     442 $        using routines pdsort and pdcomp modelled on detect and ibigr
     443 $        in the lex phase.
     444 $    7.  redo debugging package in more machine-independent fashion.
     445 $        this change includes a revision of the run-time interface.
     446 $        at user level, effect of change is as follows:
     447 $        1.  -help- parameter is now list of codes which correspond
     448 $            to initial debug statements; the codes are as follows:
     449 $            c - check index;
     450 $            e - trace entry;
     451 $            f - trace flow;
     452 $            s - trace stores;
     453 $
     454 $        the default is 'help=0' which gives no initial debug options.
     455 $        if a code list is given but includes '0', the codes are
     456 $        ignored.  'help' alone is the same as 'help=cefs'.
     457 $
     458 $        2.  the -debug- parameter selects the level of debug support:
     459 $            0 - ignore all debug statements.
     460 $            1 - process only assert statements; terminate if assert
     461 $                fails.
     462 $            2 - process all debug statements; do not terminate if
     463 $                assert fails.
     464 $            if -help- is specified, the debug level is set to two
     465 $            and the -debug- parameter is ignored.
     466 $        3.  debug statements in the -prelude- (before start of first
     467 $            procedure) are global; other debug statements are local to
     468 $            the routine in which they occur.
     469
     470
     471 $    cra       d. shields          04 may 76           level 76125
     472 $
     473 $    support revised cross-reference generation as follows.
     474 $    if cross reference option 'lcr' on, then write reference file
     475 $    3 which contains line numbers and names of subroutine definition
     476 $    lines.  use library procedure -crfnam- and parameter 'rf' to
     477 $    determine name of reference file.
     478 $    each routine is represented by several entries, as follows.
     479 $    1.  line number of start of routine (0 ends file).
     480 $    2.  number of characters in routine name.
     481 $    3.  variable number of entries, containing routine name,
     482 $        right adjusted with cpw characters per entry.
     483 $
     484 $    also, change ps to 24 for s37, and initialize littab using arglist
     485 $    to avoid multi-word data values for ha.
     486 $    decks affected - start, genini, gensub, genexit.
     487
     488
     489 $    dsa       d. shields          19 apr 76           level 76110
     490 $              r. kenner
     491 $
     492 $    1.  allow reals to occupy more than one machine word (needed for
     493 $        s16) by defining global variable -rlsz- which gives size of
     494 $        real quantity.
     495 $    2.  define size of real comparisons to be 1.
     496 $    3.  include csadump in standare table dump (tabdump).
     497 $    4.  avoid negative division in sdsnamr.
     498 $    5.  initialize nstouse to localblock in case unsized variables.
     499 $        encountered at start of program.
     500 $    6.  replace macro 'notrealcomp' with 'realcomparison' to avoid
     501 $        'negative' logic and to increase readability.
     502 $    7.  correct mispunched apostrophes in glossary.
     503 $    decks affected - gloss, start, genini, arith, gencall, genreal,
     504 $        cnvcon, emit1, emit2, sdsnamr
     505
     506
     507 $    rbka      r. kenner           24 march 1976       level 76085085
     508 $
     509 $    continue work on system/370 version, as follows:
     510 $    1.  use lctime to get time and date.
     511 $    2.  restructure table dumps to permit overlaying.  main table
     512 $        dump is now -tabdump-, which calls voadump, etc.
     513 $    3.  add variable nwarnings to count warnings, and call setcc
     514 $        to report condition code on gen termination.
     515 $    4.  clean up some of error-message handling.
     516 $    5.  give initial values for some previously uninitialized vars.
     517 $              ( the source has been resequenced )
     518
     519
     520 $    (none)    d. shields          10 february 1976    level 76041
     521 $
     522 $    the source has been cleaned up and some variables have been
     523 $    renamed.  the parser and code formerly in deck -blocken- have been
     524 $    extensively rewritten.
     525 $    this version supports all language features, including the
     526 $    recent extensions to support subscripted labels and an
     527 $    elseif clause in if statements.
     528 $    the voa layout is basically the same except that the field
     529 $    -dboup- has been added for drop bit for those operations in
     530 $    which oup field is used to hold input.
     531 $    the field 'free' is no longer used by gen.
     532 $
     533 $    the entire source has been resequenced, so this mod has no
     534 $    name.  future mods should have a name based on logical function
     535 $    if the mod adds or repairs a feature, or a name based on author
     536 $    initials for miscellaneous corrections not related to any
     537 $    one feature.
     538 $    decks affected - (all)
     539
       1 .=member  gloss
       2 $ glossary  (m denotes macro, v variable, r routine)
       3  $ ':name' indicates item is field of structure named.
       4
       5 $v  accesstab. bit vector of mba-indexes of accessed namesets.
       6 $r  advstr. advance string in lexicograhic order:'aa','ab',...'az',etc.
       7 $m  amode_real. code for amode of real (floating point) item.
       8 $m  amode. arithmetic mode (/=normal,1=real)           :voa
       9 $r  arastar. collect and list array usage statistics.(cf. genexit)
      10 $m  arb. 'is this argument of current routine'             :voa(var)
      11 $m  argbeg. starting index in -xarg- of extra values.      :voa(op)
      12 $v  argct. number of formal arguments of current routine.
      13 $m  arglen. number of -xarg- entries used.                 :voa(op)
      14 $v  arglist. parser /generator common stack, codes and ha indices.
      15 $m  argmax. dims of arglist.
      16 $m  argno. if arb set, then argument index.                :voa(var)
      17 $v  argptr. top of arglist.
      18 $r  arith. process binary operation.
      19 $m  asmhdr_vn. (voa file) version number of header block
      20 $v  asmvoadupmp. flag set by 'ad' option to get voa dump of each proc.
      21 $r  assembl. write tables for assembler use.
      22 $m  assertdim. dims of assert stack ('assert' debug request)
      23 $v  assertfg. flag, on when inside 'assert' statement expression.
      24 $v  assertst. stack of names seen in 'assert' expression.
      25 $v  assertstp. top of assertst.
      26 $v  bifatrtab. array giving names and attributes of builtin functions.
      27 $m  bifofop(op). maps opcode of builtin op into bifatrtab index
      28 $m  bifresmode(op). arithmetic mode of result of builtin function
      29 $v  bifxhasearch. flag, on to indicate xha search for function name,n.
      30 $m  bintok. lexical type of binary constant.
      31 $r  blkend. terminate basic block.
      32 $v  blkendreset. number of times blkend reset deflev field.
      33 $m  blockmax. maximum number of voa entries in basic block
      34 $m  bodylbl. -ha- index of 'body' label.                   :csa
      35 $v  buildreal. flag, on when constructing real variable.
      36 $m  builtin(op). is op a builtin function.
      37 $m  call_noparms. -gencall- code for call with no parameter list.
      38 $m  call_parms. -gencall- code for subroutine call with parameters.
      39 $m  call_value. -gencall- code for function call or indexed load.
      40 $m  calldebug(routnam). call offline debug routine.
      41 $v  cca. array of characters of constant to convert (cf. cnvcon)
      42 $v  ccaptr. position of last character in cca.
      43 $v  cclt. lexical type for constant conversion.
      44 $v  ccnchars. number of characters if inserting string const.
      45 $v  ccsyze. number of bits in converted constant value. (cf. cnvcon)
      46 $v  ccval. array containing converted constant value. (cf. cnvcon)
      47 $v  ccvalptr. number of words used in ccval. (cf. cnvcon)
      48 $v  cexpress. flag, on when parse must obtain constant expression.
      49 $m  charl(c). print character.
      50 $r  charpak(pa,ua,n). (library) pack n chars in ua into pa.
      51 $m  charofdig(d). map digit into character code.
      52 $m  chinxf. is 'check index' debug request in effect.      :ha
      53 $v  chinxfg. debug, type of check index trace in effect.
      54 $r  chinxr. process debug indexed stores check statement.
      55 $v  chinxrp. debug, global parameter to routine chinxr.
      56 $r  cnvcon. convert constants.
      57 $m  commutes(op). 'does this operator commute'
      58 $r  comptok. compare opening and closing tokens in compound statement.
      59 $m  const. is this item a constant.                        :voa
      60 $m  constok. code of lowest constant.
      61 $m  conval(hap). first word of constant value with ha index hap
      62 $m  countup(var,lim,msg). set var=var+1. fatal error if var.gt.lim
      63 $m  cpw. (ws/cs). number of characters in word.
      64 $m  cs. number of bits in character.
      65 $v  csa. c-ompound s-statement a-rray, tracks compound statements.
      66 $m  csacountup(msg). increment csa top pointer.
      67 $r  csadump. list contents of csa.
      68 $m  csamax. dims of csa (c-ompound s-tatement a-rray)
      69 $v  csaptr. top of csa.
      70 $m  csasz. size of csa entry.
      71 $v  csatok. stack of opening tokens of pending compount statements.
      72 $m  csatokmax. dims of array used for saving tokens for csa
      73 $v  csatokptr. top of csatok.
      74 $m  csiftype_else. csa cstype code for else clause.
      75 $m  csiftype_sif. csa cstype code for simple if statement
      76 $m  csiftype_then. csa cstype code for then clause.
      77 $m  csiftype. type of -if- clause.                         :csa
      78 $m  cstype_do. csa cstype code for do statemett group.
      79 $m  cstype_fnct. csa cstype code for function.
      80 $m  cstype_if. csa cstype code for if statement group.
      81 $m  cstype_subr. csa cstype code for subroutine.
      82 $m  cstype_while. csa cstype code for while statement group
      83 $m  cstype. compound statement type.                       :csa
      84 $v  curblock. voa index of first entry in current basic block.
      85 $v  currsubrname. name of current routine in sds format.
      86 $v  daopt. flag, set by 'da' option, to grant 'default access'.
      87 $m  db1. 'is this last use of first operand (inp1)'        :voa(op)
      88 $m  db2. 'is this last use of second input (inp2)'         :voa(op)
      89 $m  db3. 'is this last use of third input (inp3)'          :voa(op)
      90 $v  debugfg. flag, on when debug option(s) in effect.
      91 $v  debugsttus. flag, on if any debug option seen.
      92 $v  debugtab. stack used to communicate with rum-time debugging procs.
      93 $m  dectok. lexical type of decimal integer.
      94 $m  defaulttokenfilename. default name for token file.
      95 $m  defaultvoafilename. default name for voa file.
      96 $m  deflev. definition level of item.                      :voa
      97 $v  defnstouse. mba index of nameset to be used.
      98 $v  deind. index in debugtab.
      99 $v  denwd. number of words in debugtab entry.
     100 $v  deparm. global for macro 'callrout'.
     101 $m  digofchar(c). map character codefor digit into numeric value
     102 $m  dims. dimension value (0 if no dimension)              :voa(var)
     103 $m  dimsmax. maximum allowed value for dims.
     104 $v  docontrace. flag, on when constant values to be listed.
     105 $m  dohip. -ha- index of -hi- exprssion in -do-            :csa
     106 $m  doincp. -ha- index of 'increment' expression for 'do'  :csa
     107 $m  dolop. -ha- index of 'lo' variable in -do-             :csa
     108 $m  dosignp. 'is this descending do loop (by -)'           :csa
     109 $m  dovarp. -ha- index of -do- loop variable.              :csa
     110 $m  dsetoconst(i,c). debugtab(i) = c (c a constant)
     111 $m  dsetolvar(i,hap,nw). debugtab(i) = hap, ww words in hap
     112 $m  dsetovar(i,hap). set debuttab(i) = hap.
     113 $v  echoline. flag, on when nextok is to list line only.
     114 $m  elseiftype. csa cstype code for elseif clause.
     115 $r  emass. construct assignment representation.
     116 $v  emassrest. number of times emass reset deflev field.
     117 $r  emcall. construct call representation.
     118 $r  emit1. construct unary operation representation.
     119 $r  emit2. construct binary operation representation.
     120 $r  emit3. construct extractor representation.
     121 $v  endblock. flag, on if next call seen is to end basic block.
     122 $m  endl. end current print line, start new one.
     123 $m  endlbl. -ha- index of 'end' label ending group.        :csa
     124 $m  entrend. code for return trace.
     125 $m  entrrout. code for entry traee.
     126 $v  entrrouts. debug, stack of routines to have entry traced.
     127 $v  entrroutsp. top of entrrouts.
     128 $m  eos_code. (voa file) code for end of routine.
     129 $m  ep. index of corresponding boa entry.                  :ha
     130 $r  ermes. report semantic error.
     131 $v  ermesarg. auxiliary argument to ermes, usually ha index.
     132 $r  ermet. report syntactic error.
     133 $v  ermflag. flag, on to suppress 'unsized external' diagnostic.
     134 $r  ermlst. list boilerplate of syntactic error message.
     135 $v  ermsgno. syntactic error number.
     136 $v  everdebug. flag, set when debugging routines initialized.
     137 $m  filenamelen. maximum length of file names used by compiler
     138 $m  firstbuiltin. opcode of first intrinsic (builtin) function
     139 $m  firstst. line number of first statement in group.      :csa
     140 $v  fivtoks. flag, on if opener tokens in compount statement must match
     141 $m  flowdo. flowp code for do.
     142 $m  flowend. flowp code for return statemett processing
     143 $v  flowgen. debug, flow number generator.
     144 $m  flowgenlim. maximum number of blocks traced by 'flow' debug option
     145 $m  flowhil. flowp code for while.
     146 $m  flowiff. flowp code for -f - false.
     147 $m  flowifgt. flowp code for if...go   - true.
     148 $m  flowifnsf. flowp code for if...then...edd - if - false
     149 $m  flowifsf. flowp code for if - simple case - false.
     150 $m  flowift. flowp code fo it - true.
     151 $m  flowiftyp. trflowp field giving if typ.
     152 $m  flowlab. flowp code for label.
     153 $m  flowp. type of flow call.
     154 $v  flowrouts. debug, stack of routines to have flow traced.
     155 $v  flowroutsp. debug, top of flowrouts.
     156 $m  flowtil. flowp code for while.
     157 $v  fswitch. flag, on when compiling 'fnct', not 'subr'.
     158 $m  functyp. code for ha type 'function'
     159 $r  genacc. process access declaration.
     160 $r  genarg. process argument in routine declaration.
     161 $r  genasin. process assignment statement.
     162 $r  gencall. process call (or indexed load)
     163 $r  gencfi. process control format specification.
     164 $r  gencont. process continue statement.
     165 $r  gendat. process data declaration.
     166 $r  gendfi. process data format specification.
     167 $r  gendim. process dimension declaration.
     168 $r  gendo. process do statement.
     169 $r  genend. process end statement.
     170 $r  genexit. terminate gen compilation phase.
     171 $r  genextr. process extractor (.e., .f., .s., .ch.)
     172 $r  genfile. process file declaration.
     173 $r  genfnm. generate file name.
     174 $r  gengdi. process -get- data transmission request.
     175 $r  gengoby. process goby statement.
     176 $r  gengol. process go to or label definition (not subscripted).
     177 $r  gengosl. process subscripted label (go to or definition).
     178 $r  genif. process if statement clauses.
     179 $r  genifgo. process 'if(a1) go to a2'.
     180 $r  genini. initialize.
     181 $r  genioar. process implicit array transmission request.
     182 $r  genioit. process io data item specification.
     183 $r  geniost. process various clauses of io statements.
     184 $r  geniotr. process item for io transmission.
     185 $r  genns. process nameset declaration.
     186 $r  genpdi. process -pup- data transmission request.
     187 $r  genquit. process quit statement.
     188 $r  genreal. process real declaration.
     189 $r  genret. process return statement.
     190 $r  gensert. process debug assert statement.
     191 $r  gensiz. process size declaration.
     192 $r  gensub. process subroutine delaration (subr/fnct).
     193 $r  gentrac. process debug trace statement.
     194 $r  genuntl. process until statement.
     195 $r  genwhil. process while statement.
     196 $r  getdebug. initialize for debug package use.
     197 $r  getiov. get local variable for use in io.
     198 $m  getlpos(p). store current print line position in p.
     199 $r  getxsds. get execution time form of sds object (dense form)
     200 $m  globalblock. index in mba of first global variable block
     201 $v  gsopt. 'gs' option flag, on for globals in start.
     202 $r  gtoflo. increment pointer, abort on overflow.
     203 $m  ha_code. (voa file) code for ha block.
     204 $m  ha_vn. (voa file) version number of ha.
     205 $v  ha. common hashed array, symbols known by ha index.
     206 $m  hacont. continue ha search.
     207 $r  hadump. list contents of ha.
     208 $m  haend $ end of ha search.
     209 $r  haerr(a). print contents of ha(a) as diagnostic aid
     210 $m  hamax. dims of ha (must be prime)
     211 $v  ha_0. ha index of constant '0'.
     212 $v  ha_1. ha index of constant '1'.
     213 $m  haprobe(j, hcode). start ha search. j is index, hcode is hash.
     214 $m  haquit $ terminate ha search.
     215 $m  hascon. 'is this ha entry that of safe (short) constant'. :ha
     216 $m  hasz. size of ha.
     217 $m  hermax. maximum acceptable level for deflev check.
     218 $m  hostmachine. index of host machine.
     219 $m  ifaglob(xhap,nam). if ha(nam) corresponds to global,set xhap to xha
     220 $r  ifaglor. implement ifaglob macro, see if name in xha (with access).
     221 $v  ifaglorname. global parameter for macro 'ifaglob'.
     222 $v  ifcongoto. number of 'if' statements converted to 'go to'.
     223 $v  ifcontot. number of 'if' statements with constant expression.
     224 $m  ifnum. block number (used by debug)                    :csa
     225 $m  indebug. $ see if debug requests in effect.
     226 $m  inloc. 'register containing item address' (asm use)    :voa(var)
     227 $m  inp1. voa index of first input.                        :voa(op)
     228 $m  inp2. voa index of second input.                       :voa(op)
     229 $m  inp3. voa index of third input.                        :voa(op)
     230 $m  inreg. register holding item value (asm use)           :voa(var)
     231 $r  inscon. insert converted constant into ha.
     232 $m  insglob(glohc, namea). insert name from ha(namea) into xha, setting
     233 $r  insglor. implement insglob macro, put name into xha.
     234 $r  insname. locate name in ha (insnarg, insnchars global args).
     235 $v  insnarg. array containing name used by macro insname.
     236 $m  intl(i). print integer in five columns.
     237 $m  intlp(i,p). list integer i in p columns.
     238 $v  iobufforgm1. size of status block needed for io on file.
     239 $v  iodfitems. array of parameters for formatted transmission.
     240 $v  ioerror. flag, set when error in io to skip rest of statement.
     241 $v  iofilekeys. array of attributes given in file statement.
     242 $v  iofilename. ha index of filename for io statement.
     243 $m  ioformats. number of io formats.
     244 $v  ioformatted. flag, on when generating formatted io fragment.
     245 $v  iofts. string appended to file names to isolate them.
     246 $v  iohi. ha index of last, or high, subrscript ot array for io.
     247 $v  iokey. code of io keyword, (cf. parse)
     248 $v  iokonst. length of generated array for io file nameset.
     249 $v  iolo. ha index of first, or low, subscript of array for io.
     250 $v  ionameflag. flag, on in 'namelist' io item transmission.
     251 $v  ionames. array of names of run-time io support routines.
     252 $m  ionamesptr. number of io routines , dims of ionames
     253 $m  ior_adrf:ior_vfmt. internal codes for io library functions
     254 $v  iorts. string appended to io run-time routine names to isolate them
     255 $v  iota. stack of items that io is to transmit.
     256 $m  iotahi. (iota field) ha index of last array element to transmit
     257 $m  iotalo. (iota field) ha index of first array element to transmit
     258 $m  iotamax. dims of iota.
     259 $v  iotaptr. top of iota.
     260 $m  iotavar. (iota field) ha index of item to transmit.
     261 $v  iova. stack of local variables used by io.
     262 $v  iovabusy. string of iova indices of variables currently 'busy'.
     263 $m  iovaha. (iova field) ha index of variable.
     264 $m  iovamax. dims of iova.
     265 $v  iovaptr. top of iova.
     266 $v  iovar. ha index of item io is to transmit.
     267 $m  iovasize. (iova field) variab.
     268 $m  iovasize. (iova field) voa index of entry giving vraiable size
     269 $m  iovasz. size of iova array (io v-ariable a-rray)
     270 $v  iowriting. flag, on if compiling 'put' type statement.
     271 $m  isafnct. 'is this name used as external functon'       :voa(var)
     272 $m  isareal(x). 'is this real item', just 'amode x = amode_real'
     273 $v  isnchars. global parameter used by macro insname.
     274 $r  isusep. implement isuse macro, note use of input.
     275 $m  keeb. 'must this temporary be kept till end of block   :voa
     276 $v  keeptok. flag, set to force nextok to return current token again.
     277 $r  keycode. get io code of current token.
     278 $m  labdef(l). indicate definition point of label.
     279 $v  labgen. string giving name of last generated label.
     280 $m  labget(l). generate new label name, return lablist index in l
     281 $m  labha. index in ha of label name.                      :lablist
     282 $m  labintern. 'is this compiler generated label'          :ha
     283 $m  labldef(v, labnum). note label definition.
     284 $v  lablist. stack of label information.
     285 $m  lablistlen. maximum number of allowed labels (dims of lablist)
     286 $v  lablistptr. top of lablist.
     287 $m  labluse(labnum). note use of label in lablist(labnum)
     288 $m  labno. lablist index if name used as label.            :ha
     289 $m  labsz. size of lablist entry.
     290 $m  labuses. number of label uses.                         :lablist
     291 $m  labvoa. voa index of label definition.                 :lablist
     292 $m  lastbuiltin. opcode of last intrinsic (builtin) function
     293 $m  lastuse. 'offset of last op in block to use this value':voa(op)
     294 $m  lbtok. lexical type of h-format string constant.
     295 $v  lcp_opt. list compilation parameters option value.
     296 $v  lcs_opt. list compilation statistics option value.
     297 $m  lc_. this prefix indicates literal code value used for keywords
     298 $m  lenmax. maximum number of temporaries watched by gettemp
     299 $m  levmax. maximum definition level.
     300 $v  levmin. level used in redundant expression optimization.
     301 $v  levnow. minimum acceptable definition level for redundant comps.
     302 $v  lexlist. circular array of recent tokens seen.
     303 $m  lexlistfew. number of recent tokens listed after error
     304 $m  lexlistmax. number of recent tokens saved (must be power of 2)
     305 $v  lexlistptr. current position in lexlist.
     306 $m  lextype. lexical type of constant.                     :voa(var)
     307 $v  listsw. flag, on to list input text.
     308 $m  litclassz. size of entry in littab.
     309 $m  litcodes. number of literal codes.
     310 $m  lithasz. size of literal hash table.
     311 $m  litmax. dims of littab and litha (must be prime)
     312 $m  litsz. maximum size of literals (as sds)
     313 $v  littab. array of literal attributes (cf. macro littabl)
     314 $m  littabl(class,indx) -bronlit- codeing for ...
     315 $m  littabsz. size of littab.
     316 $m  littokorg. origin of sds littok used to hold literals as sds
     317 $v  loadha...loadxha. max. no. of entries used in arrays.
     318 $v  loadrha...loadrxha. routines with max. usage.
     319 $m  localblock. mblk code for local variable block.
     320 $v  localforce. flag, on to force allocation in local block.
     321 $v  lvgen. sds naming last generated local variable.
     322 $m  lztok. lexical type of l-format string constant.
     323 $m  macdef(text). define inner macro with body text.
     324 $m  macdrop(name). drop macro status of name.
     325 $m  madr. machine address, offset in machine block.        :voa(var)
     326 $r  marith. process unary operation.
     327 $m  maxxam. max. number of repetitions of syntactic construct allowed
     328 $m  mba_vn. (voa file) version number of mba.
     329 $v  mba. m-achine b-lock a-rray with nameset attributes.
     330 $m  mbacode. (voa file) code for mba block.
     331 $m  mbalen. length of machine block in words.              :mba
     332 $v  mbaptr. top of mba.
     333 $m  mbdef. 'is this nameset being defined in this routine' :mba
     334 $m  mbha. ha index of nameset name.                        :mba
     335 $m  mblk. machine block (mba index) of item.               :voa(var)
     336 $m  mbused. 'is this nameset used in current routine'      :mba
     337 $m  mbxha. -xha- index of nameset name.                    :mba
     338 $m  mcs. number of bits in target machine character.
     339 $m  minus. csa dosignp code for downward loop (by - ...)
     340 $m  modesize. length of amode field in voa.
     341 $m  mps. number of bits in target machine pointer or address
     342 $m  msl. length of length field for sds on target machine
     343 $m  mso. length of origin field on target machine sds.
     344 $m  mws. number of bits in target machine word.
     345 $m  m16. code for machine honeywell series 16 minicomputers
     346 $m  m37. code for machine ibm system/370.
     347 $m  m66. code for machine cdc 6600.
     348 $m  nameblockorg. origin of name block.
     349 $m  nameorg. sorg value for nam.
     350 $m  names_code. (voa file) code for names block.
     351 $m  names_vn. (voa file) version number of names.
     352 $v  names. stack giving characters of names.
     353 $m  namesmax. dims of names array.
     354 $v  namesptr. next available location in names.
     355 $m  nametok. code for lexical type of 'name' token.
     356 $m  nametok. lexical type of name.
     357 $m  naml(hap). print name of item in ha(hap)
     358 $m  namsz. size of strings used to hold sds names built internally
     359 $m  naym. ha index for this item.                          :voa
     360 $m  nayme. index in -names- of characters in name.         :ha
     361 $m  nblocks. maximum number of machine blocks.
     362 $v  ncards. number of source cards processed so far.
     363 $v  ncfopt. option flag, on if can fold to get negative constants.
     364 $v  ncftot. number of constant foldings that gave negative result.
     365 $m  nchars. number of characters in name or constant.      :ha
     366 $v  nerrors. number of detected errors.
     367 $r  nextok. get next token.
     368 $v  nl. n-ames l-ist stack giving attributes of global vars.
     369 $m  nlamode. saves 'amode'                             :nl
     370 $m  nlblk. saves 'mblk' value.                             :nl
     371 $m  nlchinx. saves 'check/nocheck' state.                  :nl
     372 $m  nldimn. holds 'dims' value.                            :nl
     373 $r  nldump. list contents of nl.
     374 $m  nlha. xha index for this variable.                     :nl
     375 $m  nlmadr. saves 'madr' value.                            :nl
     376 $m  nlmax. dims of nl.
     377 $m  nlno. -nl- index of variable.                          :xha
     378 $m  nlsize. saves 'syze' value.                            :nl
     379 $m  nlsz. size of nl entry.
     380 $m  nltrac. saves 'trace/notrace' status.                  :nl
     381 $m  no. 0 (for readability)
     382 $m  noopb. 'is this operation to be suppressed'            :voa(op)
     383 $m  nopcodes. number of opcodes (in voa)
     384 $m  notraceall. code for 'o.
     385 $m  notracesome. code for 'no trace some' debug request
     386 $v  nsflag. flag, set when inside nameset definition block.
     387 $v  nstouse. mba index of nameset to use for next size statement.
     388 $v  nsubrs. number of routines compiled.
     389 $m  numfncts. total number of library and builtin functions
     390 $v   nwarnings. number of warnings.
     391 $m  octl(i). list contents of i in octal.
     392 $m  octtok. lexical type of octal constant.
     393 $m  opb. 'is this an operation'                            :voa
     394 $m  opcode. operation code (names by macros of form 'op_') :voa(op)
     395 $v  opkind. table of operator attributes.
     396 $m  oplev. operation level for precedence parse.           :opstack
     397 $m  opofbif(op). maps bifatrtab index into opcode of builtin function
     398 $m  opstackmax. dims of opstack ,max. allowed nesting in expressions)
     399 $v  opstackp. depth of operator precedence parse.
     400 $m  optyp. operation type.                                 :opstack
     401 $m  oup. voa index of item holding result.                 :voa(op)
     402 $r  parse. the parser proper.
     403 $v  parseok. flag, on when parse automaton in 'success' state.
     404 $v  parsetrace. flag, on to trace parser in action.
     405 $m  pdotok. lexical code for period delimited operator.
     406 $m  plus. csa dosignp code for upward do loop (by +...)
     407 $m  pop(a). retrieve a from arglist.
     408 $v  proclineno. line number relative to start of current routine.
     409 $m  ps. number of bits in address or pointer.
     410 $r  psdstok. get sds form of current token.
     411 $r  pshnamr. implement pushname macro to hash name, put on arglist.
     412 $r  ptdata. data statements for parse table pt.
     413 $r  purge. cleanse tables, prepare for next routine.
     414 $m  push(hap) $ push hap onto arglist.
     415 $r  pshintr. implement pushint macro, hash const, put on arglist.
     416 $m  pushint(pcon). push short integer onto arglist
     417 $m  pushname(hc, r). push name on arglist.
     418 $r  pushr. implement push macro, push item onto arglist.
     419 $r  putvofa. put array slice onto voa file.
     420 $m  qstok. lexical type of q-format string constant.
     421 $m  quant. code for ha type 'quantity'
     422 $m  q3(a,b,c). used to define macros in macros.
     423 $m  rbtok. lexical type of d-format string constant.
     424 $m  realopcd(x). 'is opcdde that of real operation'
     425 $m  realcomparison(op). 'is this real comparison.'
     426 $m  realtok. lexical type of floating point constant.
     427 $m  rztok. lexical type of r-format string constant.
     428 $v  safeconst(a). 'is ha(a) a safe(short) constant.'
     429 $v  savetoks. number of tokens to be saved in compound statement opener
     430 $m  sds(n). size of sds item of n characters.
     431 $m  sdslit. convert token into sds form in littok.
     432 $m  sdsname(sdsnam, hap). convert ha(hap) item into sds form in sdsnamr
     433 $r  sdsnamr. implement macro sdsname, used to get sds format.
     434 $v  sdsnamstr. global scratch area for constructing strings(cf sdsname)
     435 $r  setcall. debug auxiliary, generate call to run-time debug routine.
     436 $r  setcons. debug auxiliary, set 'debugtab(deind)=deparm'.(constant)
     437 $r  setlabl. implement macro setlab, note use of label.
     438 $m  setlpos(p). set current line position to p.
     439 $r  setlvar. debug auxiliary, set 'debugtab(deind)=deparm'.(multi-word)
     440 $r  setq. verify acceptability as value-returning item.
     441 $r  setvar. debug auxiliary, set 'debugtab(deind)=deparm'.
     442 $v  sfp_opt. option flag, if on then first routine not put on voa file.
     443 $m  signbit. 'is this negatibe constant'                   :voa(var)
     444 $v  signofcon. flag, on when processing negative constant.
     445 $m  skipl(i). skip i columns on print line.
     446 $m  slabbias. upper bound on absolute value of label subscripts
     447 $m  slen. length field of sds.
     448 $m  sorg. origin field of sds.
     449 $m  spectok. code for lexical token of type special.
     450 $r  squeeze. list most recent tokens seen.
     451 $r  start. define global variables, initiate execution.
     452 $m  strtok. lexical type of sds format token.
     453 $v  subinfo. array of miscellaneous attributes passed to asm.
     454 $m  subrtyp. code for ha type 'subroutine'
     455 $m  syze. item size in bits.                               :voa
     456 $m  szmax. largest acceptable value in size specification
     457 $m  tabl(i). move to column i on print line.
     458 $v  targetmachine. integer code for target machine.
     459 $m  temb. 'is this a temporary'                            :voa(var)
     460 $m  tent. size of temporary.                               :tlist
     461 $m  testlbl. -ha- index of 'test' label.                   :csa
     462 $m  textl(s). print string.
     463 $m  tintl(s,i). print string s and integer i.
     464 $v  tlist. stack of temporary attributes. (cf. blkend)
     465 $m  tlistmax. dims of tlist.
     466 $v  tlistptr. top of tlist.
     467 $v  tmara. array of target machine parameters.
     468 $m  tmparams. number of parameters in target machine specification
     469 $v  tmtokara. array of values for converting target machine attributes.
     470 $m  tmvardef. string giving machine parameters.
     471 $m  tnext. tlist index of next temporary of same size.     :tlist
     472 $v  tokara. array with token as received from scanner.
     473 $m  tokaradims. dims of tokara.
     474 $m  tokarasz. size of tokara.
     475 $v  toklc. literal code value of current token.
     476 $v  toklen. token length in characters.
     477 $m  toklenmax. maximum token length in characters.
     478 $v  toklt. lexical type of current token.
     479 $m  toknum. number of tokens saved from opener.            :csa
     480 $m  tokorg. starting token in token list.                  :csa
     481 $v  tokrbuf. buffer for reading token file produced by scanner.
     482 $m  tokrbuflim. dims of tokrbuf (buffer used to read token file)
     483 $v  tokrbufp. current position in tokrbuf.
     484 $m  tokrcard. code for card image record on token file.
     485 $m  tokreof. code for end-of-data on token file.
     486 $m  tokrlc. token file field giving literal code of token
     487 $m  tokrlen. token file field giving token length in characters
     488 $m  tokrtyp. token file field giving token lexical type
     489 $m  tokrval. token file field giving first few hharacters of token
     490 $v  tokwords. number of tokara entries used for token.
     491 $v  tothaexam. number of ha entries examined.
     492 $v  tothaprobe. number of times ha search initiated.
     493 $m  totmachines. number of known host, target machines.
     494 $v  totwaste. number of unused machine words in tables.(cf. genexit)
     495 $m  traceall. code for 'trace all' debug reqest.
     496 $m  tracef. is 'trace stores' request in effect.           :ha
     497 $m  tracesome. code for 'trace some' debug reques.
     498 $v  trentrfg. debug, type of trace entry in effect.
     499 $v  trentrp. global for macro trentry.
     500 $r  trentrr. process debug trace entry statement.
     501 $m  trentry(t). callto debugging generator.
     502 $m  trflow(t). call to debuggigg generator.
     503 $v  trflowfg. debug, type of flow trace in effect.
     504 $v  trflowl. debug, point to ha index of label.
     505 $v  trflowp. global for macro trflow.
     506 $r  trflowr. process debug flow trace statement.
     507 $m  trroutsdim. array dims of array used to coollect subr names
     508 $v  trstorfg. debug, type of store trace in effect.
     509 $v  trstori. debug flag, on for indexing.
     510 $v  trstorp. global argument for routine trstorr.
     511 $r  trstorr. process debug assignment trace statement.
     512 $v  trstors. debug, ptr to assignment source.
     513 $v  trstor1...trstor5. globals for debug assignment trace.
     514 $m  type. quantity type.                                   :voa(var)
     515 $m  untiltyp. csa cstype code for until statemett group
     516 $m  val_code. (voa file) code for val block.
     517 $v  val. stack of converted constant values.
     518 $v  valptr. next free position in val.
     519 $m  val_vn. (voa file) version number of val.
     520 $m  valmax. dims of val.
     521 $m  var. 'is this not an operation'                        :ha
     522 $m  varpos(i). 'mblen mba(i)', current position in i-th machine block
     523 $m  vbeg. first word of constant value in -val-            :voa(var)
     524 $m  vlen. number of -val- entries used for constant value  :voa(var)
     525 $v  voa. v-ariable and o-perations a-rray. ha and voa form symbol table
     526 $m  voa_code. (voa file) code for voa block.
     527 $m  voa_vn. ,voa file) version number of voa.
     528 $m  voaasm_code. (voa file) code for routine header block
     529 $r  voadump. list contents of voa.
     530 $m  voaeof_code. (voa file) code for end of file.
     531 $m  voahdr_code. (voa file) code for header block.
     532 $m  voasz. size of voa.
     533 $m  voaup. increment voptr (top of voa)
     534 $v  vof. scratch area used to build frames for voa file.
     535 $m  vof_asmarg. (voa file header field) asmarg values.
     536 $m  vof_code. (voa header field) item code.
     537 $m  vof_debugtab. (voa file header field) value of -debugtab-
     538 $m  vof_es. (voa file header field) entry size in bits.
     539 $m  vof_hamax. (voa file header field) -hamax- (ha dims) known to gen
     540 $m  vof_ha0. (voa file header field). ha_0 value.
     541 $m  vof_ha1. (voa file header field). ha_1 value.
     542 $m  vof_hi. (voa file header field) -hi- index of array to transmit
     543 $m  vof_init. (voa file header field) -init- value.
     544 $m  vof_lablistptr. (voa file header field) vluue of lablistptr
     545 $m  vof_lo. (voa file header field) -lo- index for array
     546 $m  vof_subrargs. (voa file header field) no. of arguments of routine
     547 $m  vof_sub1. (voa file header field) subinfo(1)
     548 $m  vof_sub2. (voa file header field) subinfo(2)
     549 $m  vof_sub3. (voa file header field) subinfo(3)
     550 $m  vof_tf. (voa file header field) number of trailing data frames
     551 $m  vof_vn. (voa file header field) - version number.
     552 $m  vofsz. size of frame on voa file.
     553 $m  vomax. dims of voa.
     554 $v  voptr. next free position in voa.
     555 $m  wordl(w). print all characters in machine word w.
     556 $m  wpc. number of words for card image.
     557 $m  ws. number of bits in machine word.
     558 $m  xarg_code. (voa file) code for xarg block.
     559 $m  xarg_db. drop bit for this entry in xarg.              :xarg
     560 $m  xarg_rep. replication value for 'data' value.          :xarg
     561 $m  xarg_vn. (voa file) version number of xarg.
     562 $m  xarg_voa. voa index of item.                           :xarg
     563 $v  xarg. extra arguments array used for voa items with many inputs.
     564 $m  xargmax. dims of xarg.
     565 $v  xargptr. next free position in xarg.
     566 $m  xargsz. size of xarg.
     567 $v  xha. ha for global symbols.
     568 $m  xhabif. 'is this name of builtin function'             :xha
     569 $r  xhadump. list contents of xha.
     570 $m  xhasz. size of xha.
     571 $m  xlink. next -xha- entry with same hash code.           :xha
     572 $m  xnameptr. -xnames- index of characters in name.        :xha
     573 $v  xnames. names array for xha, holds names of globals.
     574 $m  xnamesmax. dims of xnames.
     575 $v  xnamesptr. next free position in xha.
     576 $m  xnchars. length of name in characters.                 :xha
     577 $m  xnsblk. machine block (-mba- index) of nameset.        :xha
     578 $m  yes. 1 (for readability)
     579 $m  zerents. number of zero ha entries before this one.    :ha
     580
     581
       1 .=member  macros
       2
       3      $   compilerlevel is the date of last compiler change,
       4      $   and must be updated when compiler changed.
       5      +*  compilerlevel =
rbko   9          'gen(82158)' $ 6 jun 1982
       7          **
       8
       9      +*  voafilelevel = $ julian date of last change which alters
      10          $ structure of voa file.
      11          $ subtract 76000 from date to permit representation in 16 bits
      12          76289  $ 15 october 1976.
      13          -76000 **
      14      $   conditional text options.
      15
      16      $   the conditional fragments which collect statistics may be of
      17      $   interest when bootstrapping the compiler and to periodically
      18      $   monitor compiler performance.  these fragments are usually
      19      $   omitted in a production compiler as users may be confused by
      20      $   statistics.
      21
      22      $   select haprobes to compute statistics on ha searches.
      23 .-set    haprobes
      24
      25      $   select ifconstat to compute and list statistics of number
      26      $   of -if- statements with constant inputs.
      27 .-set    ifconstat
      28
      29      $   select ncfstat to print number of negative constants seen.
      30 .-set ncfstat
      31
      32      $   select realsc to obtain constant folding of expressions in
      33      $   real constants (cf. arith).  if realsc is enabled, the
      34      $   compiler must process real constants and expressions.
      35      $   at present, code contained in realsc text is the only use
      36      $   of real contants and operations in this program.
      37 .+set realsc
      38
ldsa  23      $   select rep to enable option to produce report file.
ldsa  24      $   report written to unit repfile (nominally 6).
ldsa  25
ldsa  26 .+set rep
ldsa  27
dso    9 .+s10.
dso   10 .+set  movea_env
dso   11 .+set  movw_env
dso   12 .+set  unpk_env
dso   13 .+set  pack_env
dso   14 ..s10
utse   1 .+s32.
utse   2 .+set s32v  $ assume vms.
utse   3 ..s32
utse   4
utse   5 .+s32u.
utse   6 .+s32.
utse   7 .-set s32v  $ do not want vms.
utse   8 .+set s32u  $ want unix os.
utse   9 ..s32
utse  10 .+set mcl   $ want primary case to be lower.
utse  11 ..s32u
vax    9 .+s32.
mgfc   8 .+set movea_env,movw_env,unpk_env,pack_env
vax   11 ..s32
      39 .+s37.
      40 .+set movea_env,movw_env,unpk_env,pack_env
      41 ..s37
utsa  16 .+s47.
utsa  17 .-set movea_env,movw_env,unpk_env,pack_env
utsa  18 ..s47
      42 .+s66.
      43 .+set movw_env,unpk_env,pack_env
      44 ..s66
      45
utse  12 .+s32u. $ delete env special code for checkout.
ldsb  18 .-set movea_env,movw_env,unpk_env,pack_env
utse  13 ..s32u
      46
      47      $   define macros giving machine parameters, codes, and oft-used
      48      $   code sequences not related to any particular data structure.
      49      $   (information relevant to a particular data structure is
      50      $   given alphabetically by structure/variable name in the
      51      $   routine -start- that immediately follows the macros.)
      52
      53      $   target machine parameters
      54      +*  ws = .ws. **  $ machine word size.
      55      +*  ps = .ps. **  $ machine pointer (address) size.
      56      +*  cs = .cs. **  $ machine character size.
      57      +*  cpw = (ws/cs) **  $ characters per machine word
      58
      59
      60      $   fields of self-defining strings
      61      +*  sorg =  .e. (.sl.+1), .so., **  $ origin field of sds.
      62      +*  slen = .len. **  $ length field of sds.
      63
      64      +*  wpc = $ number of words in card image
      65 .+s66    09
vax   12 .+s32    20  $ 80 columns
      66 .+s37    20  $ 80 columns
utsa  19 .+s47    20  $ 80 columns
mgfb   8 .+s10    20
      68          **
      69
      70      $   target machine specification and identification.
      71
      72      +*  tmparams = 5 ** $ number of parameters in machine specificatio
      73      $   the previous variables -mws-, -mps-, and -mcs-
      74      $   are equated to elements in tmara to simplify initialization a
      75      $   and to ease addition of new parameters.
      76      +*  mws = tmara(1) ** $ target machine word size
      77      +*  mps = tmara(2) **  $ target machine pointer size
      78      +*  mcs = tmara(3) **  $ target machine character size
      79      +*  msl = tmara(4) ** $ target machine length of slen field
      80      +*  mso = tmara(5) **  $ length of target machine sorg field
      81
      82      +*  tmvardef = $ default tm specification taken by compiler
      83 .+s66    '6017061113'
dso   15 .+s40    '1615081616'
vax   13 .+s32    '3230081616'
utsa  20 .+s37    '3224081616'
utsa  21 .+s47    '3224081616'
mgfb   9 .+s10    '3618091818'
      86          **
      87
      88      $   macros for machine encodings
utsa  22      +*  totmachines = 8 **  $ number of known host, target machines
      90      +*  m66 = 1 **  $ cdc 6600
      91      +*  m37 = 2 **  $ ibm system/370
      92      +*  m16 = 3 **  $ honeywell series 16
      93      +*  m11 = 4 **  $ pdp-11.
      94      +*  m10 = 5 **  $ dec system/10
dso   18      +*  m40 = 6 **  $ prime 400
vax   15      +*  m32 = 7 **  $ dec vax-11
utsa  23      +*  m47 = 8 **  $ amdahl uts
      95
      96      +*  hostmachine = $ machine on which compiler runs
      97 .+s66     m66
dso   19 .+s40    m40
vax   16 .+s32     m32
      98 .+s37     m37
utsa  24 .+s47     m47
      99 .+s10    m10
     100          **
     101
     102      +*  blankword =  $ word of blank chars (see insname).
vax   17 .+s32    4r
     103 .+s37    4r
utsa  25 .+s47    4r
dso   20 .+s40    2r
     104 .+s66    10r
mgfb  10 .+s10    4r
     106          **
     107
     108
     109      $   macros related to file names
     110      +*  filenamelen = 20 ** $ max. length of file name in chars.
dsu    9 .+s32    +*  filenamelen = 64 **
utsa  26 .+s47    +*  filenamelen = 64 **
     111
dsv   12 $    getapp_len is length of actual parameter string (cf. lexini).
dsv   13          +*  getapp_len = 128  **
dsv   14 .+s32    +*  getapp_len = 240 **
utsa  27 .+s47    +*  getapp_len = 240 **
dsv   15
     112      +*  tokenfile = 3 **    $ token file number.
     113
     114      +*  voafile = 4 **      $ voa file number.
     115
     116      +*  crfile = 5 **       $ cross reference file number.
     117
ldsa  28 .+rep   +*  repfile = 6 **  $ file if rep option enabled.
dsx   22
     118      $   io access codes.
     119      +*  access_read    = 4 **
     120      +*  access_write   = 6 **
     121
     122      $   macros for listing generation (routines in run-time library).
     123
     124      +*  textl(s)   = call textlr(s);   ** $ output text
     125      +*  intl(i)    = call intlr(i);    ** $ output integer (5 digits)
     126      +*  intlp(i,p) = call intlpr(i,p); ** $ integer i in p columns
     127      +*  tintl(s,i) = call tintlr(s,i); ** $ output text+integer
     128      +*  wordl(w)   = call wordlr(w);   ** $ output word
     129      +*  charl(c)   = call charlr(c);   ** $ output single character
     130      +*  endl       = call endlr;       ** $ end line
     131      +*  getlpos(p) = call contlpr(1,p);** $ get current line pos
     132      +*  setlpos(p) = call contlpr(2,p);** $ set line position
     133      +*  skipl(i)   = call contlpr(3,i);** $ skip -i- columns
     134      +*  tabl(i)    = call contlpr(4,i);** $ tab to column -i-
     135      +*  listl(n)   = call contlpr(26,n);**  $ set listing flag
     136      +*  terml(n)   = call contlpr(27,n);**  $ set terminal flag
     137      +*  ejectl     = call contlpr(5,0);**  $ eject to new page.
     138      +*  ejectlp(n) = call contlpr(5,n);**  $ eject to new page
     139      $   if less than n lines remain on current page.
     140
     141      +*  digofchar(c) =  $ value of character digit.
     142          (c-1r0)   $ use if codes for numbers in order.
     143          **
     144      +*  charofdig(c) = $ maps digit into character code
     145          (c+1r0)  $ use if codes for numbers in order.
     146          **
     147
     148      $   countup macro for incrementing and testing variable
     149      +*  countup(var,lim,msg) =
     150          var = var+1;
     151          if (var>lim) call gtoflo(var,lim,msg); **
     152
     153
     154      $   q3 and macdef are used to define macros in macros. macdrop
     155      $   releases macro from macro status
     156
     157        +*  q3(a,b,c) = a b c  **
     158        +*  macdef(text) = q3(+,*text*,*)  **
     159        +*  macdrop(mname) = macdef(mname=)  **
     160
     161
     162      $   yes and no macros used for logical expressions to clarify
     163      $   logical intent.
     164      +*  yes = 1 **
     165      +*  no = 0 **
     166
     167      +*  blockmax = 3b'777' **  $ max length of basic block
dsw   10      +*  dimsmax =  $  maximum dimension
dsw   11 .+s10    3b'377777'
dsw   12 .+s32    4b'3fffffff'
dsw   13 .+s37    4b'3fffff'
utsa  28 .+s47    4b'3fffff'
dsw   14 .+s40    3b'177777'
dsw   15 .+s66    3b'177777'
dsw   16      **
     169      +*  levmax = 63 **  $ maximum definition level, which is the
     170      $   largest value that can be held in -deflev- field.
     171      +*  toklenmax = 150 **  $ maximum length of token in characters
     172
     173      +*  keylenmax = 20 ** $ maximum length of 'key' in io clause.
     174      +*  namsz = .sds. toklenmax **
     175      +*  nameorg = (namsz+1) **
     176
     177      $   szmax is the maximum acceptable item size.  if a larger size
     178      $   item is requested, an error message is issued and the size
     179      $   is reduced to szmax (see routine -gensiz-).  szmax also
     180      $   occurs in the run-time library text, and both values should
     181      $   be the same.
     182      +*  szmax =  $ maximum item size in bits
     183          2047
     184          **
     185      $   codes for type of call as used by generator -gencall-.
     186      +*  call_noparms = 1 **  $ no parameters, hence subroutine call
     187      +*  call_parms   = 2 **  $ subroutine call with parameter list.
     188      +*  call_value   = 3 **  $ call with value returned, must have
     189      $   parameter list. may be function call or array reference.
     190
     191      $   the following macros assign codes to literals
     192      $   these codes must be identical to the literal codes in lex
     193      +*  lc_if       =   1 **
     194      +*  lc_while    =   2 **
     195      +*  lc_until    =   3 **
     196      +*  lc_do       =   4 **
     197      +*  lc_end      =   5 **
     198      +*  lc_else     =   6 **
     199      +*  lc_size     =   7 **
     200      +*  lc_dims     =   8 **
     201      +*  lc_data     =   9 **
     202      +*  lc_semicolon=  10 **
     203      +*  lc_nameset  =  11 **
     204      +*  lc_access   =  12 **
     205      +*  lc_real     =  13 **
     206      +*  lc_call     =  14 **
     207      +*  lc_goby     =  15 **
     208      +*  lc_return   =  16 **
     209      +*  lc_elseif   =  17 **
     210      +*  lc_goin     =  18 **  $ 'in', not '.in.'
     211      +*  lc_sdsop    =  19 ** $ .sds.
     212      +*  lc_voapart  =  20 **  $ .voapart. $ for partial voa dmump
     213      +*  lc_rewind    =  21 **
     214      +*  lc_filestat =  22 **
     215      +*  lc_go       =  23 **
     216      +*  lc_cont     =  24 **
     217      +*  lc_quit     =  25 **
     218      +*  lc_fext     =  26 **  $ .f.
     219      +*  lc_eext     =  27 **   $ .e.
     220      +*  lc_sext     =  28 **          $ .s.
     221      +*  lc_chext    =  29 **  $ .ch.
     222      +*  lc_ccat     =  31 **  $  .cc.
     223      +*  lc_to       =  32 **
     224      +*  lc_or       =  33 **  $ .or.
     225      +*  lc_ex       =  34 **  $ .ex.
     226      +*  lc_exor     =  35 **  $ .exor.
     227      +*  lc_orsym    =  36 **  $ !
     228      +*  lc_and      =  37 **  $ .and.
     229      +*  lc_andsym   =  38 **  $ &
     230      +*  lc_andbrev  =  39 **  $ .a.
     231      +*  lc_eq       =  40 **  $ .eq.
     232      +*  lc_ne       =  41 **  $ .ne.
     233      +*  lc_gt       =  42 **  $ .gt.
     234      +*  lc_lt       =  43 **  $ .lt.
     235      +*  lc_ge       =  44 **  $ .ge.
     236      +*  lc_le       =  45 **  $ .le.
     237      +*  lc_eqsym    =  46 **  $ =
     238      +*  lc_ltsym    =  47 **  $ <
     239      +*  lc_gtsym    =  48 **  $ >
     240      +*  lc_notsym   =  49 ** $ ^
     241      +*  lc_plus     =  50 **  $ +
     242      +*  lc_minus    =  51 **  $ -
     243      +*  lc_times    =  52 **  $ *
     244      +*  lc_divide   =  53 **   $ /
     245      +*  lc_in       =  54 **
     246      +*  lc_not      =  55 **  $ .not.
     247      +*  lc_notbrev  =  56 **  $ .n.
     248      +*  lc_fb       =  57 **
     249      +*  lc_nb       =  58 **
     250      +*  lc_check    =  59 **
     251      +*  lc_trace    =  60 **
     252      +*  lc_assert   =  61 **
     253      +*  lc_nocheck  =  62 **
     254      +*  lc_notrace  =  63 **
     255      +*  lc_subr     =  64 **
     256      +*  lc_fnct     =  65 **
     257      +*  lc_monitor  = 66 **
     258      +*  lc_lparen   =  67 **  $ (
     259      +*  lc_rparen   =  68 **  $ )
     260      +*  lc_comma    =  69 **
     261      +*  lc_colon    =  70 **
     262      +*  lc_then     =  71 **
     263      +*  lc_by       =  72 **
     264      +*  lc_index    =  73 **
     265      +*  lc_flow     =  74 **
     266      +*  lc_stores   =  75 **
     267      +*  lc_entry    =  76 **
     268      +*  lc_voadump  =  77 **
     269      +*  lc_len      = 78 **
     270      +*  lc_pad      = 79 **  $ .pad.
     271      +*  lc_file     =  80 **
     272      +*  lc_nocontr  =  81 **
     273      +*  lc_toktr    =  82 **
     274      +*  lc_notoktr  =  83 **
     275      +*  lc_contr    =  84 **
     276      +*  lc_get      =  85 **
     277      +*  lc_put      =  86 **
     278      +*  lc_mws      =  87 **  $ .ws.
     279      +*  lc_mps      =  88 ** $ .ps.
     280      +*  lc_mcs      =  89 **  $ .cs.
     281      +*  lc_msl      =  90 **  $ .sl.
     282      +*  lc_mso      =  91 **  $ .so.
     283      +*  lc_limit    = 92 **
     284      +*  lc_read     = 93 **
     285      +*  lc_write    = 94 **
     286      +*  lc_prog     =  95 **
     287      +*  lc_seq      =  96 **  $  .seq.
     288      +*  lc_sne      =  97 **  $  .sne.
     289
     290      +*  litcodes = 97 **
     291
     292
     293      $   macros related to parser and lexical token processing
     294
     295
     296      $   (codes must agree with those assigned by lex phase.)
     297      $   the codes used in token reader routine -nextok-
     298      $   codes for lexical types assigned in lexical scan
     299      +*  toktypes = 14 ** $ no. of token types below
     300      +*  nametok  = 1 **  $  name
     301      +*  spectok  = 2 **  $  special token, e.g. (
     302      +*  pdotok   = 3 **  $  type of period delimited operators
     303      +*  dectok   = 4 **  $  type of decimal integers, e.g. 100
     304      +*  sstok = 5 **  $ special string token, e.g.,  6s...mcr
     305      +*  strtok   = 6 **
     306      +*  bittok = 8 **
     307      +*  rztok    = 12 **       $ right-zero type string constant (r)
     308      +*  realtok  = 14 **    $ real token
     309      +*  listcontroltok = 27 **  $ '.=list' directive.
     310      +*  listejecttok = 28 **  $ '.=eject' list directive.
     311      +*  listtitletok = 29 **  $ '.=title' directive.
     312      +*  tokrcard = 30 **  $ code for card image
     313      +*  tokreof  = 31 **  $ code for end-token-file
     314
     315 .+s66.
     316      +*  tokrtyp  = .f. 1, 5, **  $ token type (lex type or code)
     317      +*  tokrlen  = .f. 7, 7, **  $ length of token in chars
     318      +*  tokrlc   = .f. 14, 9, **  $ token literal code
     319 .-s66.
     320      +*  tokrtyp = .f. 1, 8, **
     321      +*  tokrlen = .f. 9, 8, **
     322      +*  tokrlc = .f. 17, 8, **
     323 ..s66
     324
     325      +*  tokrval  =  $ first few characters of short token.
     326 .+s66    .f. 25, 36,
dso   21 .+s40    .f. 25, 8,
vax   18 .+s32    .f. 25, 8,
dso   22 .+s37    .f. 25, 8,
utsa  29 .+s47    .f. 25, 8,
mgfb  11 .+s10    .f. 28, 9,
     329         **
     330
     331      +*  cpstr =  $ character per short token record
     332 .+s66    6
dso   23 .+s40    1
vax   19 .+s32    1
dso   24 .+s37    1
utsa  30 .+s47    1
mgfb  12 .+s10    1
     335          **
     336
     337      +*  constok = 4 **  $ code of first constant type
     338
     339      $   macros initializing machine blocks
     340      +*  nblocks = 63 **  $ number of loader machine blocks
     341      +*  localblock = 8 **  $ local variable block
     342      +*  globalblock = 10 **  $ global variable block
     343
     344      $   macros for ha-quantity type values
     345
     346          +*  quant = 2 **
     347          +*  subrtyp = 0 **
     348
     349
     350      +*  nopcodes = 76 **  $ number of voa opcodes.
     351
     352      +*  commutes(op) =  $ is this operator commutative.
     353      .f. 1, 1, opkind(op) **
     354
     355      +*  blkendtype(op) = $ gross type used by blkend.
     356          .f. 3, 6, opkind(op) **
     357
     358      $   macros defining opcodes of voa-operations
     359      +*  op_add        =  1 **
     360      +*  op_sub        =  2 **
     361      +*  op_gt         =  3 **
     362      +*  op_lt         =  4 **
     363      +*  op_ge         =  5 **
     364      +*  op_le         =  6 **
     365      +*  op_eq         =  7 **
     366      +*  op_ne         =  8 **
     367      +*  op_mul        =  9 **
     368      +*  op_div        = 10 **
     369      +*  op_or         = 11 **
     370      +*  op_seq        = 12 **  $ .seq.  character string equality.
     371      +*  op_and        = 13 **
     372      +*  op_exor       = 14 **
     373      +*  op_sne        = 15 **  $ .sne.  character string inequality.
     374      +*  op_nb         = 16 **  $ number of bits operation
     375      +*  op_fb         = 17 **  $ first bit operation
     376      +*  op_not        = 18 **  $ not operation
     377      +*  op_fcall      = 19 **
     378      +*  op_usub       = 19 **  $ unary minus
     379      +*  op_call       = 20 **  $ call-type operation
     380      +*  op_scall      = 20 **
     381      +*  op_pad        = 20 **    $ .pad. (not in -voa-)
     382      +*  op_asin       = 21 **  $ simple assignment operation
     383      +*  op_data       = 22 **  $ data operatio
     384      +*  op_fasin      = 23 **  $ field assignment .f.
     385      +*  op_io         = 24 **  $ binary transput
     386      +*  op_return     = 25 **  $  return
     387      +*  op_fext       = 26 **  $  extraction operation
     388      +*  op_if         = 27 **  $ if (...) go to
     389      +*  op_lab        = 28 **  $ label definition
     390      +*  op_goto       = 29 **  $ go to
     391      +*  op_goby       = 30 **
     392      +*  op_xload      = 31 **  $  indexed (array) load
     393      +*  op_xasin      = 32 **  $ indexed store
     394      +*  op_xfasin     = 33 **  $ indexed field store
     395      +*  op_ifnot      = 34 **  $ if not
     396      +*  op_ccat       = 35 **  $ .cc. operation
     397      +*  op_in         = 36 **  $ .in. operation
     398      +*  op_eext       = 37 **  $ .e. extract op
     399      +*  op_sext       = 38 **  $ .s. extract operation
     400      +*  op_easin      = 39 **  $ .e. field assignment
     401      +*  op_sasin      = 40 **  $ .s. field assignment
     402      +*  op_xeasin     = 41 **  $ .e. indexed field store
     403      +*  op_xsasin     = 42 **  $ .s. indexed field store
     404      +*  rop_add       = 43 **  $ real add
     405      +*  rop_sub       = 44 **  $ real subtract
     406      +*  rop_gt        = 45 **  $ real greater than
     407      +*  rop_lt        = 46 **  $ real less than
     408      +*  rop_ge        = 47 **  $ real greater than or equal to
     409      +*  rop_le        = 48 **  $ real less than or equal to
     410      +*  rop_eq        = 49 **  $ real equal to
     411      +*  rop_ne        = 50 **  $ real not equal to
     412      +*  rop_mul       = 51 **  $ real multiplication
     413      +*  rop_div       = 52 **  $ real division
     414      +*  rop_usub      = 53 **  $ real unary minus
     415      +*  bop_first  = 54 **  $ first built-in function
     416      +*  bop_float  = 54 **  $ integer to real
     417      +*  bop_ifix   = 55 **  $ real to integer
     418      +*  bop_abs    = 56 **  $ absolute value
     419      +*  bop_iabs   = 57 **  $ absolute value
     420      +*  bop_aint   = 58 **  $ sign of a * (largest integer <= abs(a))
     421      +*  bop_int    = 59 **  $ sign of a * (largest integer <= abs(a))
     422      +*  bop_amod   = 60 **  $ a1 mod a2
     423      +*  bop_mod    = 61 **  $ a1 mod a2
     424      +*  bop_sign   = 62 **  $ sign of a2 with abs(a1)
     425      +*  bop_isign  = 63 **  $ sign of a2 with abs(a1)
     426      +*  bop_dim    = 64 **  $ if a1 > a2 then a1-a2 else 0
     427      +*  bop_idim   = 65 **  $ if a1 > a2 then a1-a2 else 0
     428      +*  bop_exp    = 66 **  $ exponential
     429      +*  bop_alog   = 67 **  $ natural log
     430      +*  bop_alog10 = 68 **  $ common log
     431      +*  bop_sin    = 69 **  $ sine
     432      +*  bop_cos    = 70 **  $ cosine
     433      +*  bop_tanh   = 71 **  $ hyperbolic tangent
     434      +*  bop_sqrt   = 72 **  $ square root
     435      +*  bop_atan   = 73 **  $ arc tangent
     436      +*  bop_atan2  = 74 **  $ atan(a1/a2)
     437      +*  bop_last   = 74 **  $ last builtin.
     438      +*  op_list       = 75 **  $ list directive for asm.
     439
     440
     441      +*  proc_initiate = 'ltlini' ** $ initiation routine for program.
     442      +*  proc_terminate = 'ltlfin' ** $ program termination procedure.
ldse  11      +*  proc_expire = 'ltlced' **  $ check expiration date.
     443
     444
     445
     446      +*  conval(hap) = (val(vbeg voa(ep ha(hap)))) ** $ constant value
     447
     448      $   macros to pop arguments from arglist
     449
     450      +*  isuse(hap) =  $ note use of ha(hap) as input to computation
     451          call isusep(hap); **
     452      +*  ifaglob(xhap, nam) =  $ see if name is global
     453          ifaglorname = nam;  call ifaglor(xhap);  **
     454      +*  insglob(glohc, namea) =    $ insert name in globals list
     455          insgarg = namea;    $ ptr to name in ha
     456          call  insglor(glohc); **
     457
     458
     459      +*   sds(n) = .sds. (n) **  $ size of sds of n characters.
     460
     461      +*  sdsname(sdsnam, hap) =   $ converts name indicated by 'hap'
     462      $   to sds stored in sdsnam by calling routine sdsnamr
     463          call sdsnamr(hap);
     464          sdsnam = sdsnamstr; **
     465
     466      +*  naml(hap) =   $ print name of ha item
     467          call sdsnamr(hap);
     468          textl(sdsnamstr)  **  $ sdsnamr puts char string in sdsnamstr
     469
     470 $ member synmac
     471 $ syn run on    fri  17 feb 78  10:51:46
     472      +*  parsearamax = 818 **
     473      +*  parselitaramax = 0 **
     474      +*  parselexaramax = 0 **
     475      +*  parseactmax = 39 **
     476      +*  parseerrloc = 814 **
     477      +*  parseerrmax = 103 **
     478 $ end member synmac
     479      +*  ptmax = parsearamax **
     480
     481
     482
     483      +*  push(hap) =   $ push ptr onto arglist.
     484          arglist(argptr) = hap;  $ put onto stack.
     485          argptr = argptr + 1;  $ advance pointer.
     486          **
     487
     488      +*  pop(hap) = $ retrieve hap from arglist.
     489          argptr = argptr-1;  hap = arglist(argptr); **
     490
     491      +*  pushint(pcon) =   $ push integer on arg stack after
     492      $   hashing it into ha and inserting value in val array via
     493          call pshintr(pcon);  **
     494
     495      +*  pushname(hc, r) =  $ hash name into ha and names array
     496      $   push result on arglist
     497          call pshnamr(hc, r);  **
     498
     499
     500
     501      $   macros pertaining to real quantities
     502      +*  amode_real = 1 **
     503      +*  realopcd(x) = (.f. 2, 1, opkind(x)) **  $ real operation.
     504      +*  realcomparison(op) =  $ is this real comparison.
     505          ((op >= rop_gt) & (op <= rop_ne))  **
     506
dst    9      +*  arithcomparison(op) =  $ is this arithmetic comparison.
dst   10          ((op >= op_gt) & (op <= op_le))  **
dst   11
     507      $   define headers for message classes.
     508      +*  error_notice   = '*****error**** ' **
     509      +*  system_notice  = '*system error* ' **
     510      +*  warning_notice = '****warning*** ' **
     511
     512
mgfc   9 .+s10.  $ s10 wants special characters at start of error
mgfc  10          $ and warning lines.
mgfc  11      +*  warn_s10 = charl(37)  **  $ per cent for warnings.
mgfc  12      +*  error_s10 = charl(63) **  $ question mark for errors.
mgfc  13 ..s10
ldsa  29
ldsa  30 .+rep.   $   initialize rep option codes
ldsa  31
ldsa  32      +*  rep_typ = 1 **  $ type
ldsa  33      +*  rep_int = 2 **  $ integer
ldsa  34      +*  rep_nam = 3 **  $ name
ldsa  35      +*  rep_end = 4 **  $ end (of report line)
ldsa  36
ldsa  37      +*  rep_typ_c = 1 **  $ call
ldsa  38      +*  rep_typ_g = 2 **  $ global variable
ldsa  39      +*  rep_typ_n = 3 **  $ nameset
ldsa  40      +*  rep_typ_p = 4 **  $ procedure
ldsa  41
ldsa  42      +*  rep_typ_max = 4 **  $ number of rep types
ldsa  43
ldsa  44 ..rep
ldsa  45
       1 .=member  start
dso   25 .+s10    prog start;
vax   20 .+s32    prog start;
dso   26 .+s37    prog start;
utsa  31 .+s47    prog start;
dso   27 .+s66    subr start;
       4      size  proclist(1);      $ on to list procedure names and pages.
       5      data proclist = no;
       6
       7      $   define global variables and structures, in alphabetical order.
       8      $   it is assumed that this text compiled with 'default access'
       9      $   option so that every routine may refer to globals defined in
      10      $   this routine.
      11
      12      $   accesstab has bit -i- set if user is to be granted
      13      $   access to nameset at mba(i).
      14      size  accesstab(nblocks);  $ access table, indexed by blocks
      15
      16      $   argct is number of formal arguments of current routine.
      17      size  argct(ps); data argct = 0;
      18
      19      $   a data statement is used in initialization of -littab- below.
      20      $   a r g l i s t - parser/generator communication array.
      21      $   argmax is the dimension of arglist.  as the data values in
      22      $   the value list of a data statement and the labels of a goby
      23      $   statement are stacked on arglist, argmax thus gives the
      24      $   maximum length of these lists.
      25      +*  argmax = 500 **   $ dims of arglist
      26      size  argptr(ps);  data argptr = 1;  $ ptr to arglist
      27      size  arglist(ps);      $ operand push down stack
      28      dims  arglist(argmax);
      29
      30      $   the compiler option -ad- sets asmvoadump to request symbol
      31      $   table dump at end of every routine compiled.
      32      size  asmvoadump(ps);  data asmvoadump=0;  $ on for asm voa write
      33
      34      $   b u i l t i n   f u n c t i o n s.
      35      +*  numfncts = 21 **  $ total number of library and builtin fncts
      36      $   macro to test for built in fnct op
      37      +*  builtin(op) = ((op >= bop_first)&(op <= bop_last)) **
      38      $   -bifofop(op) maps opcodes for builtin operations into code
      39      $   giving position of attributes in -bifatrtab-.
      40      +*  bifofop(op) = (op-(bop_first-1)) **
      41      +*  opofbif(x)  = (x +(bop_first-1)) **  $ inverse of -bifofop-
      42
      43      size  bifatrtab(ws); dims bifatrtab(numfncts); $ attribute table
      44      data  bifatrtab = 0(numfncts);  $ filled in by -genini-
      45
      46      $   fields of -bifatrtab-
      47      +*  bfmode  = .f. 1, 01, **  $ mode of return value
      48      +*  bfext   = .f. 2, 01, **  $ 'function is off-line'
      49      +*  bfargs  = .f. 3, 02, **  $ number of arguments
      50      +*  bfalias = .f. 5, 10, **  $ -xha- index of function actually
      51      $  called (or zero if user name is to be used)
      52
      53
      54      $   flag turned on when searching for possible builtin function
      55      $   name in xha using -ifaglob- macro.
      56      size  bifxhasearch(1); data bifxhasearch = no;
      57
      58 .+haprobes.
      59      $   blkendreset is number of times blkend had to reset deflev fld.
      60      size  blkendreset(ws); data blkendreset=0;
      61 ..haprobes
      62
      63      $   buildreal is set when -real- declaration seen.
      64      size  buildreal(1);  data buildreal = 0;
      65
      66      $   constant conversion.
      67      $   constants are converted by the routine cnvcon and inserted
      68      $   into the ha by the routine inscon.
      69      $   cnvcon takes the array of characters in array cca, from
      70      $   positions 1 through ccaptr.  if the lexical type, as given
      71      $   cclt, is that of a 'safe' constant, the constant is converted
      72      $   into internal form in array -ccval-, in locations 1 through
      73      $   ccvalptr.  cnvcon sets -ccsyze- to the correct size.
      74      $   if the constant cannot be converted, it is kept in character
      75      $   form in ccval.
      76      $   string constants should be passed to cnvcon then inscon
      77      $   and not to cnvcon  directly so that character count
      78      $   ccnchars computed by cnvcon will be available to inscon.
      79      $
      80      $   inscon locates the ha index of the constant in ccval, building
      81      $   a new ha entry if necessary.
      82
      83      size  ccaptr(ps);  $ position of last character in cca.
      84      size  cca(cs); dims cca(toklenmax);
      85      size  cclt(ps); data cclt=0;  $ lexical type of constant
      86      size  ccnchars(ps); $ character count if string-type token.
      87      size  ccsyze(ps);  $ length of constant in bits
      88      size  ccvalptr(ps);  $ entries used in ccval.
      89      size  ccval(ws);  $ value array for converted constant.
      90      dims  ccval(toklenmax);
      91
      92      $   flags to indicate character extractions or assigments.
      93      size  chasflg(1); data chasflg = no;  $ character assignments
      94      size  chexflg(1); data chexflg = no;  $ character extractions
      95
dss   20      $   cis_opt is cis option value.  if nonzero, then instances
dss   21      $   of a(e) where size of e is greater than cis_opt are reported
dss   22      $   as warnings.
dss   23      size  cis_opt(ps);      $ cis option value.
      96
      97      +*  crefput(i) =  $ write entry to reference file.
      98          crbuffptr = crbuffptr + 1;
      99          crbuff(crbuffptr) = i;
     100          if  crbuffptr = crbuffmax  then  $ write full buffer
     101              call wtrwsio(crfile, iorc, crbuff, 1, crbuffptr);
     102              crbuffptr = 0;
     103              end if;
     104          **
     105      +*  crbuffmax = 256 **
     106      $   cross-reference variables.
     107      nameset gencrf;
     108      size  crfilename(sds(filenamelen));  $ name of reference file.
     109      size  crfileparm(sds(filenamelen));  $ skeleton for ref. file name
     110      size  crbuffptr(ps);  data crbuffptr= 0;
     111      size  crbuff(ws);  dims crbuff(crbuffmax);
     112      size  crossrefoption(1);  data crossrefoption = no;
     113      end nameset gencrf;
     114
     115      $   c s a .   compound statement array
     116
     117      $   the csa records the status of open, or pending, compound
     118      $   statement groups.  its dimension, csamax, gives the maximum
     119      $   depth of compound statement nesting.
     120      $   the csa fields fall into the following groups.
     121      $       flow control - testlbl, endlbl, bodylbl. most of the flow
     122      $   constructs may be divided into three parts.  a test section
     123      $   which computes the loop control expression, a body which
     124      $   contains the loop code, and an end label marking the
     125      $   start of the first statement after the compount group.
     126      $   these fields contain the ha indices of generated labels.
     127      $       do group - dovarp, dolop, dohip, dosignp, doincp.
     128      $   dovarp is the ha index of the loop variable, dolop(dohip) the
     129      $   index of the starting(ending) expression, dosignp is set for
     130      $   a descending do(' by -'), and doincp is the ha index of the
     131      $   increment expression, or by part.
     132      $       gross type - cstype, csiftype. cstype is the type of the
     133      $   entry. csiftype is used for if statements only, and gives
     134      $   the type of the various member clauses.
     135      $   token list - tokorg, toknum.  the initial tokens of the
     136      $   statement are saved in array csatok. tokorg gives the index
     137      $   of the first of the toknum entries.  the tokens are checked
     138      $   by routine comptok as part of processing for quit, cont, and
     139      $   end statements.
     140      $   debugging - firstst, ifnum. firstst is the line number,
     141      $   relative to the start of the routine, of the start of the
     142      $   group.  ifnum is the assigned block number used by flow
     143      $   trace option.
     144
     145      +*  csamax = 20  **     $ dimension of csa array
     146      +*  csasz = $ size of csa
     147 .+s66    120
vax   21 .+s32    128
     148 .+s37    128
utsa  32 .+s47    128
     149 .+s10    144
     150      **
     151
     152      +*  csatokmax = csamax*5 **  $ dimension of array for saved opener
     153      size  csa(csasz); dims csa(csamax); $ compound statement aray
     154      size  csaptr(ps);  data csaptr= 0;  $ ptr to csa
     155 .+s66.
     156      +*  bodylbl   = .f.  01, 10, **
     157      +*  oldmblk   = .f.  01, 06, **
     158      +*  endlbl    = .f.  11, 10, **
     159      +*  testlbl   = .f.  21, 10, **
     160      +*  dovarp    = .f.  31, 10, **
     161      +*  dolop     = .f.  41, 10, **
     162      +*  dohip     = .f.  51, 10, **
     163      +*  dosignp   = .f.  61, 01, **
     164      +*  doincp    = .f.  62, 10, **
     165      +*  cstype    = .f.  72, 04, **
     166      +*  csiftype  = .f.  76, 03, **
     167      +*  tokorg    = .f.  79, 07, **
     168      +*  toknum    = .f.  86, 03, **
     169      +*  firstst   = .f.  89, 11, **
     170      +*  ifnum     = .f. 100, 10, **
     171 ..s66
vax   22 .+s32.
vax   23      +*  endlbl   = .f.   1, 16, **
vax   24      +*  testlbl  = .f.  17, 16, **
vax   25      +*  cstype   = .f.  33,  8, **
vax   26      +*  tokorg   = .f.  41,  8, **
vax   27      +*  toknum   = .f.  49,  3, **
vax   28      +*  dosignp  = .f.  52,  1, **
vax   29      +*  bodylbl  = .f.  55, 10, **
vax   30      +*  oldmblk  = .f.  57,  8, **
vax   31      +*  dovarp   = .f.  65, 10, **
vax   32      +*  csiftype = .f.  65,  8, **
vax   33      +*  dolop    = .f.  76, 10, **
vax   34      +*  firstst  = .f.  86, 11, **
vax   35      +*  dohip    = .f.  97, 10, **
vax   36      +*  ifnum    = .f. 108, 11, **
vax   37      +*  doincp   = .f. 119, 10, **
vax   38 ..s32
     172 .+s37.
     173      +*  endlbl   = .f.   1, 16, **
     174      +*  testlbl  = .f.  17, 16, **
     175      +*  cstype   = .f.  33,  8, **
     176      +*  tokorg   = .f.  41,  8, **
     177      +*  toknum   = .f.  49,  3, **
     178      +*  dosignp  = .f.  52,  1, **
     179      +*  bodylbl  = .f.  55, 10, **
     180      +*  oldmblk  = .f.  57,  8, **
     181      +*  dovarp   = .f.  65, 10, **
     182      +*  csiftype = .f.  65,  8, **
     183      +*  dolop    = .f.  76, 10, **
     184      +*  firstst  = .f.  86, 11, **
     185      +*  dohip    = .f.  97, 10, **
     186      +*  ifnum    = .f. 108, 11, **
     187      +*  doincp   = .f. 119, 10, **
     188 ..s37
utsa  33 .+s47.
utsa  34      +*  endlbl   = .f.   1, 16, **
utsa  35      +*  testlbl  = .f.  17, 16, **
utsa  36      +*  cstype   = .f.  33,  8, **
utsa  37      +*  tokorg   = .f.  41,  8, **
utsa  38      +*  toknum   = .f.  49,  3, **
utsa  39      +*  dosignp  = .f.  52,  1, **
utsa  40      +*  bodylbl  = .f.  55, 10, **
utsa  41      +*  oldmblk  = .f.  57,  8, **
utsa  42      +*  dovarp   = .f.  65, 10, **
utsa  43      +*  csiftype = .f.  65,  8, **
utsa  44      +*  dolop    = .f.  76, 10, **
utsa  45      +*  firstst  = .f.  86, 11, **
utsa  46      +*  dohip    = .f.  97, 10, **
utsa  47      +*  ifnum    = .f. 108, 11, **
utsa  48      +*  doincp   = .f. 119, 10, **
utsa  49 ..s47
     189 .+s10.
     190      +*  bodylbl  = .f.   1, 18, **
     191      +*  oldmblk  = .f.   1, 18, **
     192      +*  testlbl  = .f.  19, 18, **
     193      +*  endlbl   = .f.  37, 18, **
     194      +*  dovarp   = .f.  55, 18, **
     195      +*  csiftype = .f.  55, 18, **
     196      +*  dolop    = .f.  73, 10, **
     197      +*  dohip    = .f.  83, 10, **
     198      +*  doincp   = .f.  93, 10, **
     199      +*  cstype   = .f. 103,  4, **
     200      +*  dosignp  = .f. 107,  1, **
     201      +*  firstst  = .f. 109, 11, **
     202      +*  ifnum    = .f. 120, 10, **
     203      +*  tokorg   = .f. 130,  8, **
     204      +*  toknum   = .f. 138,  3, **
     205 ..s10
     206
     207      $   type codes used in cstype field.
     208      +*  cstypes = 8 **  $ number of compound statement types.
     209      +*  cstype_subr = 1 **
     210      +*  cstype_fnct = 2 **
     211      +*  cstype_while = 3 **
     212      +*  cstype_until = 4 **
     213      +*  cstype_if = 5 **
     214      +*  cstype_do = 6 **
     215      +*  cstype_prog = 7 **
     216      +*  cstype_nameset = 8 **
     217      +*  csiftype_else = 3 **    $ special types of if statements
     218      +*  csiftype_then = 1 **
     219      +*  csiftype_sif = 2 **        $ simple if
     220      +*  csiftype_elseif = 4 **  $ elseif
     221
     222      +*  csacountup(msg) =   $ countup csa array
     223          countup(csaptr, csamax, 'csa');  $ increment csa top
     224          savetoks = 0; **  $ to start saving of tokens.
     225
     226      $   the tokens following openers and enders are saved in csatok.
     227      size  csatokptr(ps);   data csatokptr=0;  $ ptr to csatok
     228      size  csatok(ws);         $ array of opener tokens.
     229      dims  csatok(csatokmax);
     230
     231      size  curblock(ps);    $ ptr to voa for basic block beginning
     232      data  curblock = 1;
     233
     234      size  currsubrname(namsz);   $ current subr name
     235      data  currsubrname = ' ';
     236
     237      $   if da (d-efault a-ccess) compiler option on, then each routine
     238      $   is to be granted access to all namesets defined
     239      $   in the first routine compiled.
     240      size  daopt(ps);        $ on if default access is to be granted
ldse  12      size  expire(ws);       $ days to expiration.
     241
     242      $   d e b u g   f a c i l i t y.
     243
     244      $   globals relating to debug package.
     245
     246      $   macros related to debugging package
     247
     248      +*  flowgenlim = 1023 **  $ limit for no. of blocks traced
     249      +*  assertdim = 25 **  $ dimension of assert stack
     250
     251      $   values of parm to trentry routine
     252      +*  entrrout = 1 **      $ entry trace at subr or fnct
     253      +*  entrend = 2 **       $ trace print for entry at return
     254
     255      $   calls to debugging generators
     256      +*    trentry(t) = trentrp = t; call trentrr; **
     257      +*    trflow(t) = trflowp = t; call trflowr; **
     258
     259
     260      $   fields of global variable trflowp which is parameter to
     261      $   routine trflowr
     262      +*  flowp = .f. 1, 3, ** $ type of flow call (while, until, etc)
     263      +*  flowiftyp  = .f. 4, 3, **
     264      +*  flowhil  =  1 **  $ 'while' statement
     265      +*  flowtil  =  2 **  $ 'until' statement
     266      +*  flowdo   =  3 **  $ 'do' statement
     267      +*  flowift  =  4 **  $ 'if' - true
     268      +*  flowiff  =  5 **  $ 'if' - false
     269      +*  flowifsf = 3b'15' **  $ 'if' - simple case - false
     270      +*  flowifnsf = 3b'25' **  $ 'if' ... then ... end - false
     271      +*  flowifgt = 3b'14' **  $ 'if' ... go to - true
     272      +*  flowlab  =  6 **  $ label
     273      +*  flowend  = 99 **  $ print trace at return
     274
     275      size  assertfg(1);  data assertfg = 0;  $ assert flag
     276      size  assertst(ps);  dims assertst(assertdim);  $ asserstk
     277      size  assertstp(ps); data assertstp = 0;     $ ptr to assert stk
     278      size  debuglevel(2); data debuglevel = 1;  $ debug level
     279      $   0: ignore all debug statements
     280      $   1: process simple assert statements (default)
     281      $   2: process full debug options (set when -help- is specified)
     282
     283      +*  numdebugnames = 16 **  $ number of debug routines
     284      +*  dbg_prst =  1 **  $ print stores
     285      +*  dbg_pren =  5 **  $ print entry
     286      +*  dbg_prex =  6 **  $ print exit
     287      +*  dbg_prar =  7 **  $ print value of argument
     288      +*  dbg_prfl =  8 **  $ print flow trace
     289      +*  dbg_trfl =  9 **  $ trace flow
     290      +*  dbg_cinx = 10 **  $ check index
     291      +*  dbg_prhd = 11 **  $ print assert header
     292      +*  dbg_prvr = 12 **  $ print assert variable
     293      +*  dbg_asfl = 13 **  $ print assertion failed message in simple c
     294      +*  dbg_subn = 14 **  $ set subroutine info at entry
     295      +*  dbg_subx = 15 **  $ inform of subroutine exit
     296      +*  dbg_setx = 16 **  $ set run-time controls
     297
     298      size  dbgts(sds(4)); $ debug trailer string
     299      data  dbgts = '$mp';
     300
     301      size  debugnames(sds(8)); dims debugnames(numdebugnames);
     302      data  $ initialize to standard four character names
     303 $ trailing blanks eliminated when trailer added by -genini-.
     304      debugnames(dbg_prst) = 'prs3    ',  'prs4    ',
     305                             'prs5    ',  'prst    ':
     306      debugnames(dbg_pren) = 'pren    ':
     307      debugnames(dbg_prex) = 'prex    ':
     308      debugnames(dbg_prar) = 'prar    ':
     309      debugnames(dbg_prfl) = 'prfl    ':
     310      debugnames(dbg_trfl) = 'trfl    ':
     311      debugnames(dbg_cinx) = 'cinx    ':
     312      debugnames(dbg_prhd) = 'prhd    ':
     313      debugnames(dbg_prvr) = 'prvr    ':
     314      debugnames(dbg_asfl) = 'asfl    ':
     315      debugnames(dbg_subn) = 'subn    ':
     316      debugnames(dbg_subx) = 'subx    ':
     317      debugnames(dbg_setx) = 'setx    ';
     318
     319      +*  testdebug =   $ this macro test to see if debugging is ignored
     320          if  (debuglevel ^= 2) return **
     321
     322      size  dbgparm(ws), dbgchange(ws);  $ for -gendebug-
     325      size  dbgha(ps);  $ used by -gendebug- for ha pointer
     326      size  trentrp(ps);       $ global variable for trentrr
     327      size  trflowl(ps);  $ ptr to ha entry of label
     328      size  trflowp(ps);       $ global for trflowr
     329      size  trstori(1);  $ flag indicating indexing
     330      size  trstorp(ps);       $ global for trsotr
     331      size  trstors(ps);  $ ptr to source of assignemnt
     332      size  trstor1(ps);   $ globals for debug store parametrs
     333      size  trstor2(ps);
     334      size  trstor3(ps);
     335      size  trstor4(ps);
     336      size  trstor5(ps);
     337      +*  dbgspcmax = 25 **  $ numbers of vars listed in trace/check
     338      $   but not yet sized.
     339      size  dbgcspc(ps); dims dbgcspc(dbgspcmax);  $ 'check' special
     340      size  dbgcspcf(dbgspcmax);  $ 'check' flags
     341      size  dbgcspcp(ps);  $ pointer to -dbgcspc-
     342      size  dbgtspc(ps); dims dbgtspc(dbgspcmax);  $ 'trace' special
     343      size  dbgtspcf(dbgspcmax);  $ 'trace' flags
     344      size  dbgtspcp(ps);  $ pointer to -dbgtspc-
     345      size  dparm(ps), dval(1);  $ parameters to -gendebug-.
     346
meal  13      size  trentrargs(1);  $ trace entry argument list.
     347      size  trentrfg(1); $ trace entry
     348      size  trflowfg(1); $ trace flow
     349      size  trstorfg(1); $ trace stores
     350      size  chinxfg(1);  $ check index
     351      data  trentrfg = no:  trflowfg = no:
     352            trstorfg = no:  chinxfg = no;
     353
     354      size  trstorsfg(1); $ set if trace/notrace w/o namelist given
     355      size  chinxsfg(1);  $ same but for check/nocheck
     356
     357      size  gtrflowfg(1);  $ global flow trace flag
     358      size  gtrentrfg(1);  $ global entry trace flag
     359      size  gtrstorfg(1);  $ global store trace flag
     360      size  gchinxfg(1);   $ global check stores flag
     361      data  gtrflowfg = no:  gtrentrfg = no:
     362            gtrstorfg = no:  gchinxfg  = no;  $ flags are off by default
     363      size  preludefg(1); data preludefg = yes;  $ reset by first subr
     364      size  flowgen(ps);  data flowgen = 0; $ flow number generator
     365
utsa  50 .+s37.
utsa  51      $ ebcascoption is nonzero to translate char strings from
utsa  52      $ ebcdic to ascii (used for s47 bootstrap).
utsd   1      size  ebcascoption(ps);
utsa  54 ..s37
     366      size  endblock(1);  data endblock = yes; $ flag to end block
     367      $   at subr call
     368
     369      $   defaccesstab is bitstring with bit i on if nameset i defined
     370      $   if first routine, and is used to determine which namesets the
     371      $   program can access by deault if 'default access' option on.
     372      $   defaccesstab set by gensub.
     373      size  defaccesstab(nblocks);  data defaccesstab = 0;
     374
     375      size  defnstouse(ps);   $ 'default' ns to use
     376
     377      size  docontrace(1); data docontrace=no; $ on to trace constants
     378
     379      $   variables for reusing -do- variables
     380      +*  dovarmax = 32 **  $ maximum number to be used (for nested -do-
     381      size  dovars(ps); dims dovars(dovarmax); $ -ha- pointers
     382      size  dovarsz(ps); dims dovarsz(dovarmax); $ sizes
     383      size  dovarptr(ps); data dovarptr = 0;  $ no. used
     384      size  dovarbusy(dovarmax);  $ busy flags (set when var in use)
     385      data  dovarbusy = 0;  $ initially, all are free
     386      $   cardlisted is on after listing current input card.
     387      size  cardlisted(ps);  data cardlisted = yes;
     388
     389 .+haprobes.
     390      size  emassreset(ps);  data emassreset = 0;
     391 ..haprobes
     392
     393      $   ermesarg is used to pass extra information to ermes,
     394      $   usually ha index of item.
     395      size  ermesarg(ps);
     396
     397      $   ermflag is on to note calls to unsized external functions.
     398      size  ermflag(1);  data ermflag = yes;
     399
     400      size  ermsgno(ps);  $ number of error message
     401
     402      $   erthis is number of errors detected including current
     403      $   routine.  erprev is number of detected errors through
     404      $   end of previous routine.
     405      size  erthis(ps);  data erthis = 0;
     406      size  erprev(ps);  data erprev = 0;
     407
     408      size  exitcode(ps);  $ exit code from -gen-
     409      data  exitcode = 1;  $ default is bad exit (occurs more often)
     410
     411      size  fswitch(1);     $ function flag
     412      data  fswitch = 0;
     413
     414
     415
     416      size  gsopt(1);  $ on to define globals in start
     417
     418      $   h a .  hashed array.
     419
     420      $   all symbols
     421      $   names, constants and expressions are entered in the ha, and
     422      $   the ha index is main way item is referenced.  the arglist
     423      $   consists largely of ha indices.
     424
     425      $   the fields of the ha are as follows.
     426      $   ep. the index of voa for this item.
     427      $   var. 'is this a variable (ie. not operation) entry'.
     428      $   hainuse. 'is this entry in use'
     429      $   nayme. index in names array if variable name.
     430      $   nchars. number of characters in name or constant.
     431      $   labno. (for names only) lablist index if used as label.
     432      $   namintern. 'is this a compiler generated name'
     433      $   hascon. (for constants only) 'is this safe (short) constant'.
     434      $   zerents. number of preceding empty ha entries (used to
     435      $       pack ha when writing voa file).
     436      $   varluse.  last use in block of variable. (-voa- pointer)
     437      $   tracef. 'is store trace in effect.'
     438      $   chinxf. 'is check index option in effect.'
     439
     440      +*  hasz =  $ size of ha in bits
     441 .+s66   60
vax   39 .+s32   64
     442 .+s37   64
utsa  55 .+s47   64
     443 .+s10    72
     444         **
dsx   23      +*  hamax = 937 **  $ ha dims - must be a prime
     446 .+s66    nameset blank;  $ keep in blank common on s66.
     447      size  ha(hasz);  dims ha(hamax);
     448 .+s66    end nameset;
     449
     450 .+s66.
     451      +*  ep        = .f. 01, 12, **
     452      +*  hascon    = .f. 13, 01, **
     453      +*  var       = .f. 14, 01, **
     454      +*  hainuse   = .f. 15, 01, **
     455      +*  nayme     = .f. 16, 13, **
     456      +*  labno     = .f. 29, 10, **
     457      +*  tracef    = .f. 39, 01, **
     458      +*  chinxf    = .f. 40, 01, **
     459      +*  namintern = .f. 41, 01, **
     460      +*  zerents   = .f. 42, 11, **
     461      +*  varluse   = .f. 42, 11, **  $ overlays -zerents-
     462      +*  nchars    = .f. 53, 08, **
     463 ..s66
vax   40 .+s32.
vax   41      +*  hascon    = .f.  1,  1, **
vax   42      +*  var       = .f.  2,  1, **
vax   43      +*  tracef    = .f.  3,  1, **
vax   44      +*  chinxf    = .f.  4,  1, **
vax   45      +*  ep        = .f.  5, 11, **
vax   46      +*  namintern = .f. 16,  1, **
vax   47      +*  zerents   = .f. 17, 16, **
vax   48      +*  varluse   = .f. 17, 16, **
vax   49      +*  nchars    = .f. 33,  8, **
vax   50      +*  labno     = .f. 41,  9, **
vax   51      +*  hainuse   = .f. 50,  1, **
vax   52      +*  nayme     = .f. 54, 11, **
vax   53 ..s32
     464 .+s37.
     465      +*  hascon    = .f.  1,  1, **
     466      +*  var       = .f.  2,  1, **
     467      +*  tracef    = .f.  3,  1, **
     468      +*  chinxf    = .f.  4,  1, **
     469      +*  ep        = .f.  5, 11, **
     470      +*  namintern = .f. 16,  1, **
     471      +*  zerents   = .f. 17, 16, **
     472      +*  varluse   = .f. 17, 16, **
     473      +*  nchars    = .f. 33,  8, **
     474      +*  labno     = .f. 41,  9, **
     475      +*  hainuse   = .f. 50,  1, **
     476      +*  nayme     = .f. 54, 11, **
     477 ..s37
utsa  56 .+s47.
utsa  57      +*  hascon    = .f.  1,  1, **
utsa  58      +*  var       = .f.  2,  1, **
utsa  59      +*  tracef    = .f.  3,  1, **
utsa  60      +*  chinxf    = .f.  4,  1, **
utsa  61      +*  ep        = .f.  5, 11, **
utsa  62      +*  namintern = .f. 16,  1, **
utsa  63      +*  zerents   = .f. 17, 16, **
utsa  64      +*  varluse   = .f. 17, 16, **
utsa  65      +*  nchars    = .f. 33,  8, **
utsa  66      +*  labno     = .f. 41,  9, **
utsa  67      +*  hainuse   = .f. 50,  1, **
utsa  68      +*  nayme     = .f. 54, 11, **
utsa  69 ..s47
     478 .+s10.
     479      +*  ep        = .f.  1, 18, **
     480      +*  zerents   = .f. 19, 18, **
     481      +*  varluse   = .f. 19, 18, **
     482      +*  nayme     = .f. 37, 11, **
     483      +*  labno     = .f. 48,  9, **
     484      +*  nchars    = .f. 57,  8, **
     485      +*  hascon    = .f. 65,  1, **
     486      +*  var       = .f. 66,  1, **
     487      +*  tracef    = .f. 67,  1, **
     488      +*  chinxf    = .f. 68,  1, **
     489      +*  namintern = .f. 69,  1, **
     490      +*  hainuse   = .f. 70,  1, **
     491 ..s10
     492
     493      $   the following macros are to be used for all ha searches
     494      $   they correspond to 'while' over ha.  ha search begins with
     495      $   macro call of form
     496      $      haprobe(j, hcode) ,
     497      $   where j is variable used to index ha, hcode is hashcode, and
     498      $   user must size j, hcode.
     499      $   within search-body, write 'haquit', 'hacont', and 'haend' for
     500      $   actions similar to 'quit' cont  and 'end' in while statements.
     501      $   if ha is full, execution will be terminated.
     502
     503
     504      +*  haprobe(j, hcode) =  $ ha search macro
     505      hcode = mod(hcode, hamax) + 1;  $ get initial hash code.
     506      if (hcode = hamax)  hcode = (hamax-2);
     507      size  zzzp(ps);  $ probes this search.
     508      zzzp = 0;  j = 1;
     509 .+haprobes   tothaprobes = tothaprobes + 1;  $ update probe count if st
     510      macdef(haprlbl = zzza)
     511      macdef(haquitlbl = zzzc)  macdef(haendlbl = zzzd)
     512      macdef(hafulllbl = zzze)
     513      /haprlbl/ if (zzzp > hamax) go to hafulllbl; $ ha is full
     514      zzzp = zzzp + 1;
     515 .+haprobes    tothaexam = tothaexam + 1;  $ update count if ha stats on
     516      j = j + hcode;  $ add original hashcode for next probe loc
     517      if  j > hamax then  j = j-hamax;  end if;
     518      **
     519
     520      +*  hacont = go to haprlbl;**$ continue ha search
     521      +*  haquit = go to haquitlbl; **  $ quit ha search
     522      +*  haend = go to haprlbl;     $ continue ha probe
     523 /hafulllbl/ call ermes(52); call genexit;
     524      /haquitlbl/
     525      macdrop(haprlbl) macdrop(haquitlbl)
     526      macdrop(haendlbl) macdrop(hafulllbl)
     527    **
     528
     529      size  ha_0(ps);  $ ha index of constant '0' (set by gensub)
     530      size  ha_1(ps);  $ ha index of constant '1' (set by gensub)
     531      size  ifaglorname(ps);   $ global arg to ifaglor haptr to name
     532      size  iorc(ps);  $ io return code.
     533
     534
     535 .+ifconstat.
     536      $   ifcontot gives number of if's with constant control
     537      $   expression; ifcongoto is number chaaged to a go to.
     538      size  ifcontot(ws); data ifcontot=0;
     539      size  ifcongotos(ws); data ifcongotos=0;
     540 ..ifconstat
     541
     542      $  the next few variables are primarily used as part of macro
     543      $   expansion to pass macro parameters to routines.
     544      size  insnchars(ps);   $ arg to insnamr - nchars
     545      size  insgarg(ps);   $ global to hasher (globals)  ptr to ha
     546      size  insnarg(ws);  $ array holding name to be added
     547      dims  insnarg(namsz/ws);  $ packed array of token characters
     548
     549      $   i n p u t / o u t p u t  s u p p o r t.
     550
     551      +*  iotamax = 40 **  $ dims of iota
     552
     553      size  iowriting(1);  $ 'is this put statement'
     554      size  ioformatted(1);  $ set for formatted io
     555      size  iolistmode(1);    $ on for list mode.
     556
     557      $   items to be transmitted, either expressions, variables or arra
     558      $   are noted in the iota (io t-ransmission a-rray).  the fields
     559      $   -iotavar-, -iotalo- and -iotahi- give the ha indices of the
     560      $   item, the first element of array slice and last element of
     561      $   array slice (lo and hi 0 if not array slice).
     562
     563      size  iota(ws); dims iota(iotamax);
     564      size  iotaptr(ps); data iotaptr=0; $ top of iota
     565      size  iovar(ps);  $ ha index of item to transmit
     566      size  iolo(ps);   $ ha index of array subscript or start of slice
     567      size  iohi(ps);   $ ha index of end of array slice
     568
     569      $   the status of local variables needed for io is maintained in
     570      $   the iova (io v-ariable a-rray) with top -iovaptr- adnd limit
     571      $   -iovamax-.  the field -iovaha- gives ha index of variable,
     572      $   -iovasize- gives its size in bits.  the i-th bit of -iovabusy-
     573      $   is set if the i-th variable in iova is currently in use.
     574      $   the busy bits are cleared when variable no longer needed
     575      $   to permit reuse within io statement, and at start of io statem
     576      $   ment since variables only needed in single statement.
     577
     578      +*  ioformats = 6 **  $ number of data formats.
     579
     580
     581
     582
     583       +*  ionamesptr = 19 **  $ number of io routines to which calls ge
     584       +*  ior_onma =  1 **  $ -n- array element name
     585       +*  ior_onmv =  2 **  $ -n- simple name list
     586       +*  ior_gcfp =  3 **  $ control format processor
     587       +*  ior_ifma =  4 **  $ -a- input format
     588       +*  ior_ifmb =  5 **  $ -b- input format
     589       +*  ior_ifme =  6 **  $ -e- input format
     590       +*  ior_ifmf =  7 **  $ -f- input format
     591       +*  ior_ifmi =  8 **  $ -i- input format
     592       +*  ior_ifmr =  9 **  $ -r- input format
     593       +*  ior_rwnd = 10 **  $ file rewind
     594       +*  ior_ioqu = 11 **  $ io query
     595       +*  ior_vali = 12 **  $  validator.
     596       +*  ior_makf = 13 **  $ make system tables for file
     597       +*  ior_ofma = 14 **  $ -a- output format
     598       +*  ior_ofmb = 15 **  $ -b- output format
     599       +*  ior_ofme = 16 **  $ -e- output format
     600       +*  ior_ofmf = 17 **  $ -f- output format
     601       +*  ior_ofmi = 18 **  $ -i- output format
     602       +*  ior_ofmr = 19 **  $ -r- output format
     603
     604
     605
     606      $   fields of iota (io t-ransmission a-rray)
     607      +*  iotavar = .e. 01, 10, **  $ ha index of item to transmit
     608      +*  iotalo  = .e. 11, 10, **  $ ha index of first array element
     609      +*  iotahi  = .e. 21, 10, **  $ ha index of last array elementn
     610
     611      $   iova (io v-ariable a-rray) fields
     612      +*  iovaha = .e. 1, 10, **  $ ha index of variable
     613      +*  iovasize = .e. 11, 11, **  $ size of variable
     614
     615      +*  iovasz = 20 ** $ size of iova
     616      +*  iovamax = 40 **  $ maximum number of entries in iova
     617
     618      size  iovaptr(ps);  data iovaptr=0; $ top of iova
     619      size  iova(iovasz); dims iova(iovamax);
     620      size  iovabusy(iovamax); data iovabusy = 0;
     621
     622      size  iofilename(ps); data iofilename = 0;  $ ha index of filename
     623      size  iokey(ps);       $ io token key word. passed from
     624      $   parser to generators
     625      size  ioerror(1); data ioerror = no; $ error flag
     626      size  ionameflag(1); data ionameflag = no; $ namelist flag
     627      size  iofilekeys(ps); dims iofilekeys(4); $ args for file definiti
     628      $   the i/o functions are supported by various routines in the
     629      $   little run-time library.  to avoid name conflicts between
     630      $   these routines and user routines, the compiler supports an
     631      $   option to 'protect' i/o names.
     632
     633      $   within the source, io routines are reffered to by macros.
     634      $   these macros expand to indices into the array -ionames- below.
     635      $   the routine names are initially given as four characters.
     636      $   these routines are protected by appending a trailer string
     637      $   as part of the compiler isolation, the trailer will typically
     638      $   contain a character acceptable to the loader but not
     639      $   usually found in subprogram names (for example, '$').
     640
     641      $   the default trailer is an implementation option, but
     642
     643
     644      $   the trailer can be at most 4 characters
     645
     646      size  iorts(sds(4)); $ io routine trailer string
     647      data  iorts = '$io';
     648
     649      size  ionames(sds(8)); dims ionames(ionamesptr);
     650      data   $ initialize to standard four character names
     651      $   trailing blanks eliminated by genini.
     652      ionames(ior_onma) = 'onma    ':  $ -n- array element name
     653      ionames(ior_onmv) = 'onmv    ':  $ -n- simple name list
     654      ionames(ior_gcfp) = 'gcfp    ':  $ control format processor
     655      ionames(ior_ifma) = 'ifma    ':  $ -a- input format
     656      ionames(ior_ifmb) = 'ifmb    ':  $ -b- input format
     657      ionames(ior_ifme) = 'ifme    ':  $ -e- input format
     658      ionames(ior_ifmf) = 'ifmf    ':  $ -f- input format
     659      ionames(ior_ifmi) = 'ifmi    ':  $ -i- input format
     660      ionames(ior_ifmr) = 'ifmr    ':  $ -r- input format
     661      ionames(ior_rwnd) = 'rwnd    ':  $ file rewind
     662      ionames(ior_ioqu) = 'ioqu    ':  $ io query
     663      ionames(ior_vali) = 'vali    ':  $  validator.
     664      ionames(ior_makf) = 'makf    ':  $ make system tables for file
     665      ionames(ior_ofma) = 'ofma    ':  $ -a- output format
     666      ionames(ior_ofmb) = 'ofmb    ':  $ -b- output format
     667      ionames(ior_ofme) = 'ofme    ':  $ -e- output format
     668      ionames(ior_ofmf) = 'ofmf    ':  $ -f- output format
     669      ionames(ior_ofmi) = 'ofmi    ':  $ -i- output format
     670      ionames(ior_ofmr) = 'ofmr    ';  $ -r- output format
     671
     672      $   array iodfprocs maps codes for data formats onto codes use
     673      $   for formatted conversion routines.  the first -ioformats-
     674      $   are for input, the rest for output.
     675      size  iodfprocs(ps);  dims iodfprocs(2*ioformats);
     676      data  iodfprocs =
     677          ior_ifma,  ior_ifmb,  ior_ifme,  ior_ifme,
     678          ior_ifmi,  ior_ifmr,  ior_ofma,  ior_ofmb,
     679          ior_ofme,  ior_ofmf,  ior_ofmi,  ior_ofmr;
     680
     681      $   several of the parameters needed for formatted io are
     682      $   packed into various fields of the io parameter string;
     683      $   data structures and procedures related to this packing have
     684      $   names beginning with -iops-.
     685      $   iopssz is the size of the string.  the array iopsha is a list
     686      $   of the ha indexes of the parameters to be entered.
     687      $   parameters are assumed to be zero unless otherwise specified,
     688      $   so iopsha entries are set to ha_0 initially.
     689      $   the arrays iopsorg and iopslen give the origins and lengths of
     690      $   the fields.  macros beginning with 'iopsi_' give integer
     691      $   codes for the fields.
     692      $   the procedure -geniops- constructs the parameter string
     693      $   and sets the global variable -iopshap- to the ha index;
     694      $   if all the fields are constants, the string will be a constant
     695      $   otherwise, the string is built by entering all constant fields
     696      $   at compile time and generating code to enter nonconstant
     697      $   field values at runtime.
     698      +*  iopsflds = 7 **  $ number of fields in iops.
     699      +*  iopssz = 32 ** $ size of iops.
     700      size  iopshap(ps);      $ ha index of io parm. str.
     701      size  iopsha(ps);  dims iopsha(iopsflds);  $ ha indices of parms.
     702      size  iopsorg(ps);  dims iopsorg(iopsflds);
     703      size  iopslen(ps);  dims iopslen(iopsflds);
     704      +*  iopsi_lm = 1 **  $ on if list mode.
     705      +*  iopsi_fw = 2 **  $ field width.
     706      +*  iopsi_dw = 3 **  $ decimal width (also byte width).
     707      +*  iopsi_sz = 4 **  $ size of datum.
     708      +*  iopsi_gw = 5 **  $ group width.
     709      data  $ set field origins of iops fields.
     710          iopsorg(iopsi_lm) = 01:  iopslen(iopsi_lm) = 01:
     711          iopsorg(iopsi_fw) = 02:  iopslen(iopsi_fw) = 08:
     712          iopsorg(iopsi_dw) = 10:  iopslen(iopsi_dw) = 05:
     713          iopsorg(iopsi_sz) = 17:  iopslen(iopsi_sz) = 11:
     714          iopsorg(iopsi_gw) = 28:  iopslen(iopsi_gw) = 04;
     715      $   bit iopssz is reserved for use when machine word size
     716      $   is less than iopssz (see procedure geniops).
     717
     718      size  isusenot(1);  data isusenot = no;  $ flag for -isuse- macro.
     719      size  keeptok(1); data keeptok=no; $ on to retrieve last token.
     720
     721      $   l a b e l  p r o c e s s i n g.
     722
     723
     724      +*  lablistlen =   $ dimension of label list
     725          400
     726          **
     727
     728      +*  labsz = ws **    $ size of lablist entry
     729      size  labgen(sds(4));  data labgen = 'l.aa'; $ local label name
     730 .+s66    nameset blank;  $ keep in blank common on s66.
     731      size  lablist(labsz); dims lablist(lablistlen);  $ label table
     732 .+s66    end nameset;
     733      size  lablistptr(ps);  data lablistptr = 0;     $ ptr to lablist
     734      $   the lablist fields are as follows.
     735      $   labha is the ha index of the entry for label.
     736      $   labvoa is the voa index of the item for label definition.
     737
     738 .+s66.
     739      +*  labha   = .f. 01, 10, **
     740      +*  labvoa  = .f. 11, 11, **
     741 ..s66
vax   54 .+s32.
vax   55      +*  labha   = .f.  1, 16, **
vax   56      +*  labvoa  = .f. 17, 16, **
vax   57 ..s32
     742 .+s37.
     743      +*  labha   = .f.  1, 16, **
     744      +*  labvoa  = .f. 17, 16, **
     745 ..s37
utsa  70 .+s47.
utsa  71      +*  labha   = .f.  1, 16, **
utsa  72      +*  labvoa  = .f. 17, 16, **
utsa  73 ..s47
     746 .+s10.
     747      +*  labha   = .f.  1, 18, **
     748      +*  labvoa  = .f. 19, 18, **
     749 ..s10
     750
     751      $   macros relating to the handling of labels
     752
     753      $   define label by entering voaptr in lablist
     754      +*  labldef(v, labnum) =
     755          if  labvoa lablist(labnum)  then  $ if already defined,
     756              if  (namintern ha(labha lablist(labnum)) = no)
     757                  call ermes(14);  $ duplicate label.
     758          else
     759              labvoa lablist(labnum) = v; end if;
     760             **
     761
     762      $   increment number of uses of label
     763      +*  labluse(labnum) =
     764          labuses lablist(labnum) = labuses lablist(labnum) + 1;  **
     765
     766      +*  labget(labl) = $ returns ha ptr to label
     767          call advstr(labgen, labl);  $ advance local label name ,hash
     768          **
     769
     770      +*  labdef(labl) =  $ define label
     771          push(labl)  call gengol(op_lab);  **
     772
     773      $   lcp_opt on to list compilation parameters.
     774      $   lcs_opt on to list compilation statistics.
     775      size  lcp_opt(ps);  data lcp_opt = yes;
     776      size  lcs_opt(ps);  data lcs_opt = yes;
     777
     778      $   levnow and levmin are used to detect redundant calculations.
     779      $   levnow is incremented for each basic block, and minlev is set
     780      $   to the value of levnow at this point, so an operation has
     781      $   been performed in the current block only if its definition
     782      $   level is not less than levmin.  levnow is also incremented for
     783      $   each assignment and the deflev field of the assignment target
     784      $   is set to the new value.
     785      $   an operation is redundant if both the computation itself and
     786      $   the computation of any inputs which are not variables have
     787      $   been performed in the current block and if no input has been
     788      $   assigned a new value since the prior computation.
     789      $   the search for redundant computations is performed in routines
     790      $   emit1, emit2 and emit3.
     791      size  levnow(ps);  data  levnow = 1;    $ level number
     792      size  levmin(ps);  data levmin=1;  $ minimum level - optimization
     793
     794      $   t o k e n   a n d   l i t e r a l   p r o c e s s i n g.
     795
     796      $   as a diagnostic aid, a list of the most recent tokens
     797      $   is maintained in lexlist with dimension -lexlistmax-.
     798      $   lexlist holds list of recent tokens seen, for diagnostics
     799      +*  lexlistmax =   $ number of words listed in 'last few tokens'
     800 .+s66    16
vax   58 .+s32    16*2  $ two words/token
     801 .+s37    16*2  $ two words/token
utsa  74 .+s47    16*2  $ two words/token
dso   28 .+s10    16*2  $ two words/token
     803          **
     804
     805      $   -lexlistmax- must be a power of two.
     806      +*  lexlistsz = ws **  $ size of lexlist entry.
     807      size  lexlist(lexlistsz); dims lexlist(lexlistmax);
     808      size  lexleng(lexlistsz); dims lexleng(lexlistmax);
     809      data  lexlist = 0(lexlistmax);
     810      size  lexlistptr(ps); data lexlistptr = 0;
     811
     812      size  listingcode(1);   $ assembler code list option value.
     813      data  listingcode = no;  $ by default, do not list code.
     814      size  subtitling(1);     $ set when entering subtitles.
     815      data  subtitling = no;
     816      size  listsw(1);     $ flag for listing input
     817      data  listsw = no;  $  by default, list off.
     818      $   listswnew holds new listsw value until next line read.
     819      $   the initial value must be same as that for listsw.
     820      size  listswnew(1);  data listswnew = no;
     821      size  listauto(1); data listauto = no;  $ auto-titleing flag
     822      size  listwds(ws); dims listwds(wpc);  $ card read in
     823      size  listwdsp(ps);   $ last non-blank word
     824
     825      size  toklc(ps);  $ token literal code
     826
     827      +*  litclassz =  $ size of littab internal entry.
     828 .+s66    6
vax   59 .+s32    8
     829 .+s37    8
utsa  75 .+s47    8
     830 .+s10    6
     831         **
     832
     833      +*  littabl(class, indx) = $ computeentry in littab for given
     834      $   literal and class
     835          .f. (littabsz+1) - litclassz*(class), litclassz, littab(indx)
     836          **
     837
     838      +*  littabsz =   $ size of littab (at least 60 bits)
     839 .+s66    60
vax   60 .+s32    128
     840 .+s37    128
utsa  76 .+s47    128
     841 .+s10    72
     842         **
     843
     845      size  littab(littabsz);  dims littab(litcodes);  $ leteral class
     846      data  littab = 0(litcodes); $ see ltabini for initialization code.
     847
     848      $   to save space, we initialize the literals table as follows.
     849      $   abstractly, -littab- is a two dimensional table, littab(cl,lc)
     850      $   indexed by -cl-, a class number, and -lc- a literal code.
     851      $   for example, the set of binary operator names is one such
     852      $   class, and the littab entry for binary operators contains
     853      $   the precedence of the operator (0 if not binary op).
     854      $   the table is a set of triples .
     855      $   the macros below are used to enter values in arglist as initia
     856      $   data and deflit is called to build littab.
     857      $   this roundabout procedure saves code space which formerly
     858      $   by using execution time field extracts to set up each entry.
     859
     860      data arglist =
     861      +*  ins(lc,value ) =
     862          lc + value*4b'100', **
     863
     864       1*4b'100',
     865      ins(lc_if, 1)
     866      ins(lc_while, 2)
     867      ins(lc_until , 3)
     868      ins(lc_do, 4)
     869      ins(lc_end, 5)
     870      ins(lc_else, 6)
     871      ins(lc_size, 7)
     872      ins(lc_dims, 8)
     873      ins(lc_data, 9)
     874      ins(lc_semicolon,10)
     875      ins(lc_nameset, 11)
     876      ins(lc_access, 12)
     877      ins(lc_real,13)
     878      ins(lc_elseif, 14)
     879      ins(lc_subr, 15)
     880      ins(lc_fnct, 16)
     881      ins(lc_divide, 17)
     882      ins(lc_prog, 18)
     883
     884      $   branch on literals - simple statements
     885       2*4b'100',
     886      ins(lc_call, 1)
     887      ins(lc_goby, 2)
     888      ins(lc_return, 3)
     889      ins(lc_go, 4)
     890      ins(lc_cont, 5)
     891      ins(lc_quit, 6)
     892      ins(lc_fext, 7)
     893      ins(lc_eext, 8)
     894      ins(lc_sext, 9)
     895      ins(lc_chext, 10)
     896      ins(lc_get, 11)
     897      ins(lc_put, 12)
     898      ins(lc_file, 13)
     899      ins(lc_rewind, 14)
     900      ins(lc_len, 15)
     901      ins(lc_read, 16)
     902      ins(lc_write, 17)
     903      ins(lc_check, 18)
     904      ins(lc_nocheck, 19)
     905      ins(lc_trace, 20)
     906      ins(lc_notrace, 21)
     907      ins(lc_assert, 22)
     908      ins(lc_monitor, 23)
     909
     910      $   binary operators - operator precedence level nubers
     911       3*4b'100',
     912      ins(lc_pad, 1)
     913      ins(lc_ccat, 1)
     914      ins(lc_or, 1)
     915      ins(lc_ex, 1)
     916      ins(lc_exor, 1)
     917      ins(lc_orsym, 1)
     918      ins(lc_and, 2)
     919      ins(lc_andsym, 2)
     920      ins(lc_andbrev, 2)
     921      ins(lc_eq, 4)
     922      ins(lc_ne, 4)
     923      ins(lc_gt, 4)
     924      ins(lc_lt, 4)
     925      ins(lc_ge, 4)
     926      ins(lc_le, 4)
     927      ins(lc_eqsym, 4)
     928      ins(lc_ltsym, 4)
     929      ins(lc_gtsym, 4)
     930      ins(lc_notsym, 4)
     931      ins(lc_seq, 4)  $ .seq.
     932      ins(lc_sne, 4)  $ .sne.
     933      ins(lc_plus, 5)
     934      ins(lc_minus, 5)
     935      ins(lc_times, 6)
     936      ins(lc_divide, 6)
     937      ins(lc_in, 6)
     938
     939      $   unary operators - operator prec level numbers
     940       4*4b'100',
     941      ins(lc_not, 3)
     942      ins(lc_notbrev, 3)
     943      ins(lc_notsym, 3)
     944      ins(lc_fb, 7)
     945      ins(lc_nb, 7)
     946      ins(lc_minus, 7)
     947      ins(lc_sdsop, 7)
     948      ins(lc_len, 7)
     949      ins(lc_plus, 7)  $ unary plus.
     950
     951      $   binary operators - arith routine parameter number - opcode
     952       5*4b'100',
     953      ins(lc_ccat, op_ccat)
     954      ins(lc_in, op_in)
     955      ins(lc_plus, op_add)
     956      ins(lc_minus, op_sub)
     957      ins(lc_gt, op_gt)
     958      ins(lc_gtsym, op_gt)
     959      ins(lc_lt, op_lt)
     960      ins(lc_ltsym, op_lt)
     961      ins(lc_ge, op_ge)
     962      ins(lc_le, op_le)
     963      ins(lc_eq, op_eq)
     964      ins(lc_eqsym, op_eq)
     965      ins(lc_ne, op_ne)
     966      ins(lc_notsym, op_ne)
     967      ins(lc_times, op_mul)
     968      ins(lc_divide, op_div)
     969      ins(lc_or, op_or)
     970      ins(lc_orsym, op_or)
     971      ins(lc_and, op_and)
     972      ins(lc_andbrev, op_and)
     973      ins(lc_andsym, op_and)
     974      ins(lc_exor, op_exor)
     975      ins(lc_ex, op_exor)
     976      ins(lc_seq, op_seq)
     977      ins(lc_pad, op_pad)
     978      ins(lc_sne, op_sne)
     979
     980      $   unary operators - marith routine parameter number - opcode
     981       6*4b'100',
     982      ins(lc_fb, op_fb)
     983      ins(lc_nb, op_nb)
     984      ins(lc_not, op_not)
     985      ins(lc_notsym, op_not)
     986      ins(lc_notbrev, op_not)
     987      ins(lc_minus, op_usub)
     988      ins(lc_sdsop, 0)  $ .sds.
     989      ins(lc_len, 1)   $ .len.
     990      ins(lc_plus, 2)
     991
     992      $   branch on literals - right hand terms
     993       7*4b'100',
     994      $   assigned code is offset to which to branch forward in
     995      $   parse of terms.
     996      ins(lc_fext, 5)
     997      ins(lc_eext, 6)
     998      ins(lc_sext, 7)
     999      ins(lc_chext, 8)
    1000      ins(lc_lparen, 9)
    1001      ins(lc_filestat, 10)
    1002
    1003      $   codes for special tokens examined by nextok.
    1004       9*4b'100',
    1005      ins(lc_voadump ,  1)
    1006      ins(lc_voapart ,  2)
    1007      ins(lc_contr   ,  5)
    1008      ins(lc_nocontr ,  6)
    1009      ins(lc_toktr   ,  7)
    1010      ins(lc_notoktr ,  8)
    1011      ins(lc_mws     ,  9)
    1012      ins(lc_mps     , 10)
    1013      ins(lc_mcs     , 11)
    1014      ins(lc_msl     , 12)
    1015      ins(lc_mso     , 13)
    1016
    1017    0, 0;  $ end of data statement for ha (0 flags end of list)
    1018          +*  ins = **  $ drop ins macro.
    1019
    1020
    1021
    1022      $   a record is kept of the maximum use of each static array and
    1023      $   the routine compiled which made maximum use.
    1024      +*  loadini(var,varsds) = $ initialize load statistics variable.
    1025          size  var(ws); data var = 0;
    1026          size  varsds(namsz); data varsds = ' ';
    1027          **
    1028      loadini(loadha      , loadrha      );  $ ha.
    1029      loadini(loadlablist , loadrlablist );  $ lablist.
    1030      loadini(loadnames   , loadrnames   );  $ names.
    1031      loadini(loadtlist   , loadrtlist   );  $ tlist.
    1032      loadini(loadval     , loadrval     );  $ val
    1033      loadini(loadvoa     , loadrvoa     );  $ voa.
    1034      loadini(loadxarg    , loadrxarg    );  $ xarg.
    1035      macdrop(loadini)
    1036
    1037      size  localforce(1);  data localforce=no; $ on to force use
    1038      $   of local block by gensiz (set by gendo)
    1039
    1040      size  lvgen(sds(4)); data lvgen = 'v.aa'; $ local variable name
    1041
    1042      $   mainprogram is set when compiling program.
    1043      size  mainprogram(1);  data mainprogram = no;
    1044      $   m b a .  machine block array
    1045      size  mbaptr(ps);  data mbaptr=0;  $ most recent entry in mba
    1046
    1047      +*  mbasz =  $ size of mba (m-achine b-lock a-rray)
    1048 .+s66   60
dsw   17 .+s32   96
dsw   18 .+s37   96
utsa  77 .+s47   96
    1050 .+s10    72
    1051         **
    1052
    1053      size  mba(mbasz);  dims mba(nblocks);  $ m-achine b-lock a-rray
    1054      data  mba = 0(nblocks);
    1055
    1056 .+s66.
    1057      +*  mblen   = .f.  1, 20, **
    1058      +*  mbha    = .f. 21, 11, **
    1059      +*  mbused  = .f. 32,  1, **
    1060      +*  mbxha   = .f. 33, 12, **
    1061      +*  mbdef   = .f. 46,  1, **
    1062      +*  mbchain = .f. 47, 11, **
    1063 ..s66
vax   62 .+s32.
vax   63      +*  mbused  = .f.  1,  1, **
vax   64      +*  mbdef   = .f.  2,  1, **
vax   65      +*  mbha    = .f.  4, 11, **
dsw   19      +*  mblen   = .f. 65, 32, **
vax   67      +*  mbxha   = .f. 33, 13, **
vax   68      +*  mbchain = .f. 46, 11, **
vax   69 ..s32
    1064 .+s37.
    1065      +*  mbused  = .f.  1,  1, **
    1066      +*  mbdef   = .f.  2,  1, **
    1067      +*  mbha    = .f.  4, 11, **
dsw   20      +*  mblen   = .f. 65, 32, **
    1069      +*  mbxha   = .f. 33, 13, **
    1070      +*  mbchain = .f. 46, 11, **
    1071 ..s37
utsa  78 .+s47.
utsa  79      +*  mbused  = .f.  1,  1, **
utsa  80      +*  mbdef   = .f.  2,  1, **
utsa  81      +*  mbha    = .f.  4, 11, **
utsa  82      +*  mblen   = .f. 65, 32, **
utsa  83      +*  mbxha   = .f. 33, 13, **
utsa  84      +*  mbchain = .f. 46, 11, **
utsa  85 ..s47
    1072 .+s10.
    1073      +*  mblen   = .f.  1, 18, **
    1074      +*  mbxha   = .f. 19, 18, **
    1075      +*  mbha    = .f. 37, 18, **
dst   12      +*  mbchain = .f. 55, 11, **
dst   13      +*  mbused  = .f. 66,  1, **
dst   14      +*  mbdef   = .f. 67,  1, **
    1079 ..s10
    1080
    1081      $   characters in symbolic names are kept in -names- array.
    1082      +*  namesmax =   $ dimension of -names- array
    1083 .+s66    600
vax   70 .+s32    800
    1084 .+s37    800
utsa  86 .+s47    800
mgfb  13 .+s10    800
    1086          **
    1087
    1088      size  namesptr(ps);  data namesptr = 1;  $ ptr to names array
    1089 .+s66    nameset blank;  $ keep in blank common on s66.
    1090      size  names(ws); dims names(namesmax);  $ names array
    1091 .+s66    end nameset;
    1092
    1093      size  ncards(ps); data ncards = 0;  $ number of cards read.
    1094
    1095      size  ncfopt(1); data ncfopt=1;  $ on if negative constant fold ok
    1096 .+ncfstat.
    1097      size  ncftot(ps);  data ncftot=0;$ no. of negative constants fold
    1098 ..ncfstat
    1099
    1100      size  nerrors(ps);  data nerrors = 0;  $ no of errors
    1101      size  nwarnings(ps);  data nwarnings=0; $ num. of warnings.
    1102
    1103      $   n l - names list (attributes of global variables)
    1104
    1105      +*  nlmax =   $ dimension of -nl- array
    1106          400
    1107          **
    1108
    1109      size  nlptr(ps);  data nlptr = 0;  $ top of nl
    1110      $   fields related to global names list  -  n l
    1111      +*  nlsz =   $ size of nl
    1112 .+s66   120
dsw   21 .+s32   96
dsw   22 .+s37   96
utsa  87 .+s47   96
    1114 .+s10    72
    1115         **
    1116
    1117 .+s66    nameset blank;  $ keep in blank common on s66.
    1118      size  nl(nlsz);  dims nl(nlmax);
    1119 .+s66    end nameset;
    1120
    1122
    1123 .+s66.
    1124      +*  nldimn  = .f.  1, 16, **
    1125      +*  nlmadr  = .f. 17, 16, **
    1126      +*  nlha    = .f. 33, 10, **
    1127      +*  nlamode = .f. 43,  1, **
    1128      +*  nlchinx = .f. 44,  1, **
    1129      +*  nlsize  = .f. 45, 11, **
    1130      +*  nltrac  = .f. 56,  1, **
    1131      +*  nlfnct  = .f. 57,  1, **
    1132      +*  nlblk   = .f. 61,  6, **
    1133 ..s66
vax   72 .+s32.
dsw   23      +*  nldimn  = .f.  1, 32, **
dsw   24      +*  nlmadr  = .f. 65, 32, **
vax   75      +*  nlsize  = .f. 33, 11, **
vax   76      +*  nlblk   = .f. 44,  6, **
vax   77      +*  nlamode = .f. 50,  1, **
vax   78      +*  nlchinx = .f. 51,  1, **
vax   79      +*  nltrac  = .f. 52,  1, **
vax   80      +*  nlfnct  = .f. 53,  1, **
vax   81      +*  nlha    = .f. 55, 10, **
vax   82 ..s32
    1134 .+s37.
dsw   25      +*  nldimn  = .f.  1, 32, **
dsw   26      +*  nlmadr  = .f. 65, 32, **
    1137      +*  nlsize  = .f. 33, 11, **
    1138      +*  nlblk   = .f. 44,  6, **
    1139      +*  nlamode = .f. 50,  1, **
    1140      +*  nlchinx = .f. 51,  1, **
    1141      +*  nltrac  = .f. 52,  1, **
    1142      +*  nlfnct  = .f. 53,  1, **
    1143      +*  nlha    = .f. 55, 10, **
    1144 ..s37
utsa  88 .+s47.
utsa  89      +*  nldimn  = .f.  1, 32, **
utsa  90      +*  nlmadr  = .f. 65, 32, **
utsa  91      +*  nlsize  = .f. 33, 11, **
utsa  92      +*  nlblk   = .f. 44,  6, **
utsa  93      +*  nlamode = .f. 50,  1, **
utsa  94      +*  nlchinx = .f. 51,  1, **
utsa  95      +*  nltrac  = .f. 52,  1, **
utsa  96      +*  nlfnct  = .f. 53,  1, **
utsa  97      +*  nlha    = .f. 55, 10, **
utsa  98 ..s47
    1145 .+s10.
    1146      +*  nldimn  = .f.  1, 18, **
    1147      +*  nlmadr  = .f. 19, 18, **
    1148      +*  nlha    = .f. 37, 10, **
    1149      +*  nlamode = .f. 47,  1, **
    1150      +*  nlblk   = .f. 48,  6, **
    1151      +*  nlchinx = .f. 54,  1, **
    1152      +*  nltrac  = .f. 55,  1, **
    1153      +*  nlfnct  = .f. 56,  1, **
    1154      +*  nlsize  = .f. 57, 11, **
    1155 ..s10
    1156
    1157      size  nsflg(1); data nsflg=0; $ on when inside nameset.
    1158      size  nstouse(ps);       $ nameset to use in next size stttement
    1159      data  nstouse = localblock;
    1160
    1161      size  nsubrs(ps); data nsubrs = 0;  $ number of subrs seen
    1162      size  ntexterr(1); data ntexterr = no;  $ on if certain errors
    1163      $   detected outside of subroutine to prevent run-away errors
    1164
    1165      $   o p e r a t o r  a t t r i b u t e s.
    1166
    1167      $   opkind array, indexed by operator code, gives 'gross' operator
    1168      $   type used by blkend and also indicates if operator commutes.
    1169      $   commutativity information unpacked in genini, later accessed
    1170      $   used -commutesatr- macro.
    1171      size  opkind(ws);  dims opkind(nopcodes);
    1172
    1173      $   operator attributes are entered in the opkind array using the
    1174      $   -op- macro below.  three attributes are currently defined -
    1175      $   - blkendtype, used by blkend to determine pattern in voa.
    1176      $   - commutativity, used by emit2 to standardize commutative ops
    1177      $   in order to detect more redundant expressions.
    1178      $   -realopcd- is set for amode=amode_real ops.
    1179
    1180      +*  op(opc, gc, c, r) = opkind(opc) = 4*gc + 2*r + c **
    1181      data
    1182          op(op_add    , 03, yes, no):
    1183          op(op_sub    , 03, no , no):
    1184          op(op_gt     , 03, no , no):
    1185          op(op_lt     , 03, no , no):
    1186          op(op_ge     , 03, no , no):
    1187          op(op_le     , 03, no , no):
    1188          op(op_eq     , 03, yes, no):
    1189          op(op_ne     , 03, yes, no):
    1190          op(op_mul    , 03, yes, no):
    1191          op(op_div    , 03, no , no):
    1192          op(op_or     , 03, yes, no):
    1193          op(op_and    , 03, yes, no):
    1194          op(op_exor   , 03, yes, no):
    1195      $   opcode not used
    1196          op(op_nb     , 02, no , no):
    1197          op(op_fb     , 02, no , no):
    1198          op(op_not  , 02, no , no):
    1199          op(op_fcall  , 05, no , no):
    1200          op(op_call   , 06, no , no):
    1201          op(op_asin   , 07, no , no):
    1202          op(op_data   , 01, no , no):
    1203          op(op_fasin  , 09, no , no):
    1204          op(op_io     , 15, no , no): $ unformatted io
    1205          op(op_return , 01, no , no):
    1206          op(op_fext   , 04, no , no):
    1207          op(op_if     , 11, no , no):
    1208          op(op_lab    , 01, no , no):
    1209          op(op_goto   , 01, no , no):
    1210          op(op_goby   , 11, no , no):
    1211          op(op_xload  , 16, no , no):
    1212          op(op_xasin  , 08, no , no):
    1213          op(op_xfasin , 10, no , no):
    1214          op(op_ifnot  , 11, no , no):
    1215          op(op_ccat   , 03, no , no):
    1216          op(op_in     , 03, no , no):
    1217          op(op_eext   , 04, no , no):
    1218          op(op_sext   , 04, no , no):
    1219          op(op_easin  , 09, no , no):
    1220          op(op_sasin  , 09, no , no):
    1221          op(op_xeasin , 10, no , no):
    1222          op(op_xsasin , 10, no , no):
    1223          op(rop_add   , 12, yes, yes):
    1224          op(rop_sub   , 12, no , yes):
    1225          op(rop_gt    , 13, no , yes):
    1226          op(rop_lt    , 13, no , yes):
    1227          op(rop_ge    , 13, no , yes):
    1228          op(rop_le    , 13, no , yes):
    1229          op(rop_eq    , 13, yes, yes):
    1230          op(rop_ne    , 13, yes, yes):
    1231          op(rop_mul   , 12, yes, yes):
    1232          op(rop_div   , 12, no , yes):
    1233          op(rop_usub  , 14, no , yes):
    1234          op(bop_float , 02, no , yes):
    1235          op(bop_ifix  , 02, no , no):
    1236          op(bop_abs   , 02, no , yes):
    1237          op(bop_iabs  , 02, no , no):
    1238          op(bop_aint  , 02, no , yes):
    1239          op(bop_int   , 02, no , no):
    1240          op(bop_amod  , 03, no , yes):
    1241          op(bop_mod   , 03, no , no):
    1242          op(bop_sign  , 03, no , yes):
    1243          op(bop_isign , 03, no , no):
    1244          op(bop_dim   , 03, no , yes):
    1245          op(bop_idim  , 03, no , no):
    1246          op(bop_exp   , 02, no , yes):
    1247          op(bop_alog  , 02, no , yes):
    1248          op(bop_alog10, 02, no , yes):
    1249          op(bop_sin   , 02, no , yes):
    1250          op(bop_cos   , 02, no , yes):
    1251          op(bop_tanh  , 02, no , yes):
    1252          op(bop_sqrt  , 02, no , yes):
    1253          op(bop_atan  , 02, no , yes):
    1254          op(bop_atan2 , 03, no , yes):
    1255          op(op_list   , 01, no , no):
    1256          op(op_seq    , 03, yes, no):
    1257          op(op_sne    , 03, yes, no);
    1258
    1259      +*  op = **  $ drop macro.
    1260
    1261      size  opstackp(ps); data opstackp=0;  $ ptr to opstack
    1262
    1263      size  parsereg(ps);  dims  parsereg(8);   $ registers of parse mac
    1264
    1265      size  parsetrace(1);  data parsetrace = no;
    1266
ldsa  46 .+rep.
ldsa  47      $   rep_opt on if generating report file.
ldsa  48      size  rep_opt(ps);
ldsa  49      size  rep_opt_c(1);  $ on if reporting calls
ldsa  50      size  rep_opt_p(1);  $ on if reporting procedure definitions
ldsa  51      size  rep_opt_g(1);  $ on if reporting global storage allocation
ldsa  52      size  rep_suffix(.sds. 5);  $ report suffix code
ldsa  53 ..rep
ldsa  54
    1267      size  pelvalue(ps);    $ error limit
    1268
    1269      $   proclineno is line number relative to start of current
    1270      $   procedure.
    1271      size  proclineno(ps);  data proclineno = 0;
    1272
    1273      size  rlsz(ps);  $  size of real (floating point) quanitty.
    1274
    1275
    1276      $   'replication' variables used by gendat.  replication is switch
    1277      $   set wheh data replication requested in data value list.
    1278      $   replication_origin records position in arglist at start of
    1279      $   data list processing.  replicate is bit string, with bit i on
    1280      $   if arglist(i) contains a replication value and not data value.
    1281
    1282      size  replicate(argmax);
    1283      size  replication(1);
    1284      size  replication_origin(ps);
    1285
    1286      $   safeconst is array, indexed by lexical type, with non-zero
    1287      $   entry if constants of corresponding type can safely be
    1288      $   evaluated at compile time.
    1289      size  safeconst(ps);  dims safeconst(toktypes);
    1290      data  safeconst = 0(toktypes); $ assume all unsafe, correct this
    1291      $   assumption in genini.
    1292
    1293
    1294      size  savetoks(ps); data savetoks=5;  $ conter of saved tokens
    1295
    1296      size  sdsnamstr(namsz); data sdsnamstr=0; $ parameter to sdsnamr.
    1297
    1298      size  setqfok(1);  data setqfok = no;  $ switch for -setq-.
    1299
    1300      size  sfp_opt(1); data sfp_opt = no;  $ suppress first routine
    1301
    1302      size  signofcon(1);  data signofcon=0;  $ constant sign(1 is minus
    1303
    1304
    1305      size  subinfo(ps);  dims subinfo(3);  $ subr/fnct info array
    1306
    1307      size  targetmachine(ps);  $ index of target machine
    1308      data  targetmachine = hostmachine;
    1309
    1310      +*  tlistmax = $ dimension of -tlist- (no. of temporaries)
ldsd  16          60
    1312          **
    1313
    1314 .+s66    nameset blank;  $ keep in blank common on s66.
    1315      size  tlist(ws);  dims tlist(tlistmax);  $ temporaries list
    1316 .+s66    end nameset;
    1317      size  tlistptr(ps);  data tlistptr=0; $ top of tlist.
    1318      +*  tokrbuflim = 256 **
    1319      +*  tokarasz = ws **  $ size of tokara
    1320      +*  tokaradims = ((toklenmax+cpw)/cpw) **
    1321      size  tokara(tokarasz); dims tokara(tokaradims); $ token array
    1322      size  toklen(ps);  $ token length in characters
    1323      size  toklt(ps);  $ token lexical type
    1324 .+s66    nameset blank;  $ keep in blank common on s66.
    1325      size  tokrbuf(ws);  dims tokrbuf(tokrbuflim);  $ token buffer
    1326 .+s66    end nameset;
    1327      size  tokrbufp(ps);  data tokrbufp=0;  $ ptr to tokrbuf
    1328      size  tokwords(ps);  $ no of words in token value
    1329
    1330      size  tmara(ws);  dims tmara(tmparams); $ target machine parameter
    1331      size  tmtokara(tokarasz); dims tmtokara(tmparams);
    1332
    1333 .+haprobes.
    1334      size  tothaexam(ws); data tothaexam=0;  $ no of times ha looped
    1335      size  tothaprobes(ws);  data tothaprobes=0; $ no of ha probes
    1336 ..haprobes
    1337      size  totwaste(ps); data totwaste=0; $ unused memory words
    1338
    1339      $   v a l .  (used to hold constant values)
    1340      +*  valmax =   $ dimension of -val- array
    1341 .+s66    0700
vax   83 .+s32    1100
    1342 .+s37    1100
utsa  99 .+s47    1100
mgfb  14 .+s10    1100
    1344          **
    1345
    1346      size  valptr(ps); data  valptr = 1;   $ ptr to val array
    1347 .+s66    nameset blank;  $ keep in blank common on s66.
    1348      size  val(ws);  dims val(valmax);  $ holds constant values
    1349 .+s66    end nameset;
    1350
    1351      $   v o a .  variable / operations array
    1352
    1353      +*  voasz =  $ size of voa
    1354 .+s66    120
dsw   27 .+s32    192
dsw   28 .+s37    192
utsa 100 .+s47    192
    1356 .+s10    144
    1357      **
    1358      +*  vomax =  $ dimension of -voa-
    1359          1850
    1360          **
    1361
    1362      size  voptr(ps);    $ ptr to voa
    1363      +*  voafnct = 1 **
    1364      data  voptr = voafnct;  $ ready to begin definition
    1365
    1366      size  voa(voasz);  dims voa(vomax);
    1367 .+s66    nameset blank;  $ keep in blank common on s66.
    1368      size  voawrt(1);  $ on if writing voa file
    1369 .+s66    end nameset;
    1370      $   v o a   f i e l d s
    1371
    1372      $   fields common to both -operation- and -quantity- operations
    1373
    1374 .+s66.
    1375      +*  deflev = .f. 1, 6, **   $ definition level
    1376      +*  keeb = .f. 7, 1, **  $ keep bit for holding till blkend
    1377      +*  naym = .f. 8, 10, **  $ ha ptr
    1378      +*  opb = .f. 18, 1, **  $ 'is this an operation'
    1379      +*  syze = .f. 19, 11, **  $ entry size in bits
    1380      +*  amode = .f. 118, 1, **    $ real or integer mode
    1381
    1382      $   voa field for -variable' or non-operation entries (opb = no)
    1383
    1384      +*  arb = .f. 30, 1, **     $ argument bit
    1385      +*  argno = .f. 31, 5, **   $  argument no of parameter
    1386      +*  const = .f. 36, 1, **   $ on if 'constant'
    1387      +*  dimn = .f. 37, 16, **   $ dimension of array (or 0 if no dimn)
    1388      +*  vlen = .f. 55, 5, **    $ no of words in constant value
    1389      +*  temb = .f. 60, 1, **    $ on if 'temporary'
    1390      +*  voanl = .f. 61, 9, **  $ pointer to -nl- for global
    1391      +*  madr = .f. 70, 16, **   $ machine address of item
    1392      +*  mblk = .f. 86, 6, **    $ machine block of item
    1393      +*  type = .f. 92, 2, **    $ quantity type
    1394      +*  vbeg = .f. 94, 12, **   $ start of const val in -val- array
    1395      +*  signbit = .f.106,1, **  $ sign of constant (0=+, 1=-)
    1396      +*  lextype = .f. 107,5, **  $ lexical type of constant
    1397      +*  isafnct = .f. 113,1, **  $ set when name used as function name
    1398      +*  varnuse = .f. 114, 4, **  $ number of uses of var.
    1399      +*  varnusemax = 1b'1111' **  $ max of -varnuse- field
    1400      +*  isavar = .f. 119, 1, **   $ 'used as variable'
    1401
    1402      $   fields for operation type entries
    1403
    1404
    1405      +*  argbeg = .f. 30, 9, **  $ beginning of extra arguments
    1406      +*  arglen = .f. 39,  9, **   $ number of extra arguments
    1407      +*  db1 = .f. 49, 1, **     $ drop bit for input 1
    1408      +*  db2 = .f. 50, 1, **     $ drop bit for input 2
    1409      +*  db3 = .f. 51, 1, **     $ drop bit for input 3
    1410      +*  opcode = .f. 52, 7, **
    1411      +*  seblk = .f. 59, 1, **  $ indicates if scall ends block
    1412      +*  bytaln = .f. 60, 1, **  $ indicates char. extract or assign
    1413      +*  inp1 = .f. 61, 12, **   $ voa index of first input
    1414      +*  inp2 = .f. 73, 12, **   $ voa index of second input
    1415      +*  inp3 = .f. 85, 12, **   $ voa index of third input
    1416      +*  oup = .f. 97, 12, **    $ voa index of output
    1417      +*  lastuse = .f. 109, 9, **$ voa index of last use of op
    1418      +*  dboup = .e. 119, 01, ** $ drop bit if oup used as input.
    1419 ..s66
    1420
vax   85 .+s32.
vax   86      +*  amode   = .f.   1,  1, **
vax   87      +*  keeb    = .f.   2,  1, **
vax   88      +*  opb     = .f.   3,  1, **
vax   89      +*  naym    = .f.   4, 10, **
vax   90      +*  syze    = .f.  17, 16, **
vax   91      +*  deflev  = .f.  33,  6, **
vax   92
vax   93      +*  const   = .f.  14,  1, **
vax   94      +*  temb    = .f.  15,  1, **
vax   95      +*  signbit = .f.  16,  1, **
vax   96      +*  isafnct = .f.  39,  1, **
vax   97      +*  voanl   = .f.  40,  9, **
dsw   29      +*  dimn    = .f.  129, 32, **
dss   24      +*  varnuse = .f.  65,  8, **
dss   25      +*  varnusemax = 4b'ff' **
dss   26      +*  mblk    = .f.  73,  7, **
dss   27      +*  isavar  = .f.  80,  1, **
dsw   30      +*  madr    = .f.  161, 32, **
dss   29      +*  vlen    = .f.  97,  8, **
dss   30      +*  lextype = .f. 105,  4, **
dss   31      +*  argno   = .f. 109,  5, **
dss   32      +*  arb     = .f. 114,  1, **
dss   33      +*  type    = .f. 115,  2, **
dss   34      +*  vbeg    = .f. 117, 12, **
vax  110
vax  111      +*  db1     = .f.  14,  1, **
vax  112      +*  db2     = .f.  15,  1, **
vax  113      +*  db3     = .f.  16,  1, **
vax  114      +*  arglen  = .f.  39,  9, **
vax  115      +*  dboup   = .f.  48,  1, **
vax  116      +*  inp1    = .f.  49, 16, **
vax  117      +*  inp2    = .f.  65, 11, **
vax  118      +*  lastuse = .f.  76, 10, **
vax  119      +*  inp3    = .f.  86, 11, **
vax  120      +*  opcode  = .f.  97,  8, **
vax  121      +*  seblk   = .f. 105,  1, **
vax  122      +*  bytaln  = .f. 106,  1, **
vax  123      +*  argbeg  = .f. 107, 10, **
vax  124      +*  oup     = .f. 118, 11, **
vax  125 ..s32
    1421 .+s37.
    1422      +*  amode   = .f.   1,  1, **
    1423      +*  keeb    = .f.   2,  1, **
    1424      +*  opb     = .f.   3,  1, **
    1425      +*  naym    = .f.   4, 10, **
    1426      +*  syze    = .f.  17, 16, **
    1427      +*  deflev  = .f.  33,  6, **
    1428
    1429      +*  const   = .f.  14,  1, **
    1430      +*  temb    = .f.  15,  1, **
    1431      +*  signbit = .f.  16,  1, **
    1432      +*  isafnct = .f.  39,  1, **
    1433      +*  voanl   = .f.  40,  9, **
dsw   31      +*  dimn    = .f.  129, 32, **
dst   15      +*  varnuse = .f.  65,  8, **
dst   16      +*  varnusemax = 4b'ff' **
dst   17      +*  mblk    = .f.  73,  7, **
dst   18      +*  isavar  = .f.  80,  1, **
dsw   32      +*  madr    = .f.  161, 32, **
dst   20      +*  vlen    = .f.  97,  8, **
dst   21      +*  lextype = .f. 105,  4, **
dst   22      +*  argno   = .f. 109,  5, **
dst   23      +*  arb     = .f. 114,  1, **
dst   24      +*  type    = .f. 115,  2, **
dst   25      +*  vbeg    = .f. 117, 12, **
    1446
    1447      +*  db1     = .f.  14,  1, **
    1448      +*  db2     = .f.  15,  1, **
    1449      +*  db3     = .f.  16,  1, **
    1450      +*  arglen  = .f.  39,  9, **
    1451      +*  dboup   = .f.  48,  1, **
    1452      +*  inp1    = .f.  49, 16, **
    1453      +*  inp2    = .f.  65, 11, **
    1454      +*  lastuse = .f.  76, 10, **
    1455      +*  inp3    = .f.  86, 11, **
    1456      +*  opcode  = .f.  97,  8, **
    1457      +*  seblk   = .f. 105,  1, **
    1458      +*  bytaln  = .f. 106,  1, **
    1459      +*  argbeg  = .f. 107, 10, **
    1460      +*  oup     = .f. 118, 11, **
    1461 ..s37
utsa 101 .+s47.
utsa 102      +*  amode   = .f.   1,  1, **
utsa 103      +*  keeb    = .f.   2,  1, **
utsa 104      +*  opb     = .f.   3,  1, **
utsa 105      +*  naym    = .f.   4, 10, **
utsa 106      +*  syze    = .f.  17, 16, **
utsa 107      +*  deflev  = .f.  33,  6, **
utsa 108
utsa 109      +*  const   = .f.  14,  1, **
utsa 110      +*  temb    = .f.  15,  1, **
utsa 111      +*  signbit = .f.  16,  1, **
utsa 112      +*  isafnct = .f.  39,  1, **
utsa 113      +*  voanl   = .f.  40,  9, **
utsa 114      +*  dimn    = .f.  129, 32, **
utsa 115      +*  varnuse = .f.  65,  8, **
utsa 116      +*  varnusemax = 4b'ff' **
utsa 117      +*  mblk    = .f.  73,  7, **
utsa 118      +*  isavar  = .f.  80,  1, **
utsa 119      +*  madr    = .f.  161, 32, **
utsa 120      +*  vlen    = .f.  97,  8, **
utsa 121      +*  lextype = .f. 105,  4, **
utsa 122      +*  argno   = .f. 109,  5, **
utsa 123      +*  arb     = .f. 114,  1, **
utsa 124      +*  type    = .f. 115,  2, **
utsa 125      +*  vbeg    = .f. 117, 12, **
utsa 126
utsa 127      +*  db1     = .f.  14,  1, **
utsa 128      +*  db2     = .f.  15,  1, **
utsa 129      +*  db3     = .f.  16,  1, **
utsa 130      +*  arglen  = .f.  39,  9, **
utsa 131      +*  dboup   = .f.  48,  1, **
utsa 132      +*  inp1    = .f.  49, 16, **
utsa 133      +*  inp2    = .f.  65, 11, **
utsa 134      +*  lastuse = .f.  76, 10, **
utsa 135      +*  inp3    = .f.  86, 11, **
utsa 136      +*  opcode  = .f.  97,  8, **
utsa 137      +*  seblk   = .f. 105,  1, **
utsa 138      +*  bytaln  = .f. 106,  1, **
utsa 139      +*  argbeg  = .f. 107, 10, **
utsa 140      +*  oup     = .f. 118, 11, **
utsa 141 ..s47
dso   30 .+s10.
dso   31      +*  amode   = .f.   1,  1, **
dso   32      +*  keeb    = .f.   2,  1, **
dso   33      +*  opb     = .f.   3,  1, **
dso   34      +*  naym    = .f.   4, 10, **
dso   35      +*  syze    = .f.  17, 11, **
dso   36      +*  deflev  = .f.  28,  6, **
dso   37
dso   38      +*  const   = .f.  14,  1, **
dso   39      +*  temb    = .f.  15,  1, **
dso   40      +*  signbit = .f.  16,  1, **
dso   41      +*  isafnct = .f.  37,  1, **
dso   42      +*  inreg   = .f.  38,  8, **
dso   43      +*  ppdata  = .f.  46,  1, **
dso   44      +*  voanl   = .f.  38,  9, **
dso   45      +*  vlen    = .f.  47,  8, **
dso   46      +*  lextype = .f.  55,  4, **
dso   47      +*  frsdata = .f.  47, 12, **
dso   48      +*  argno   = .f.  59,  5, **
dso   49      +*  mblk    = .f.  64,  6, **
dso   50      +*  arb     = .f.  70,  1, **
dso   51      +*  isavar  = .f.  71,  1, **
dso   52      +*  type    = .f.  73,  2, **
dsw   33      +*  dimn    = .f.  75, 17, **
dsw   34      +*  madr    = .f.  92, 17, **
dst   26      +*  vbeg    = .f. 109, 12, **
dst   27      +*  varnuse = .f. 121,  8, **
dso   57      +*  varnusemax = 4b'ff' **
dso   58
dso   59      +*  db1     = .f.  14,  1, **
dso   60      +*  db2     = .f.  15,  1, **
dso   61      +*  db3     = .f.  16,  1, **
dso   62      +*  arglen  = .f.  37,  9, **
dso   63      +*  dboup   = .f.  46,  1, **
dso   64      +*  inp1    = .f.  47, 11, **
dso   65      +*  inp2    = .f.  58, 11, **
dso   66      +*  seblk   = .f.  69,  1, **
dso   67      +*  bytaln  = .f.  70,  1, **
dso   68      +*  inp3    = .f.  73, 11, **
dso   69      +*  lastuse = .f.  84, 10, **
dso   70      +*  oup     = .f.  94, 11, **
dso   71      +*  opcode  = .f. 109,  7, **
dso   72      +*  argbeg  = .f. 116, 10, **
dso   73 ..s10
    1503      $   macro voaup counts up the voa ptr
    1504      +*  voaup =  $ increment voa top pointer
    1505          countup(voptr, vomax, 'voa'); **
    1506
    1507      size  voafilename(ws);  $ name of voa file
    1508      $   v o a   f i l e   m a c r o s
    1509      +*  vofsz =  $ size of voa file header frame.
vax  126 .+s32    256
    1510 .+s37    256
utsa 142 .+s47    256
    1511 .+s66    240
    1512 .+s10    288
    1513          **
    1514
    1515      +*  voa_level = .e. 17, 16, **  $ julian date of last change
    1516          $ relative to 1 jan 1976 (ie, juliandate - 76000).
    1517      $   *** when change array size or fields, update version no. ***
    1518
    1519      $   codes for items in voa-file
    1520      +*  voaeof_code = 0 ** $ marks end of file
    1521      +*  voahdr_code = 1 ** $ file header code
    1522      +*  voaasm_code = 2 ** $ routine header code
    1523      +*  voa_code =    3 ** $ voa
    1524      +*  ha_code =    4** $ ha
    1525      +*  names_code =  5 ** $ names array
    1526      +*  xarg_code =   6 ** $ xarg array
    1527      +*  val_code  =  7 ** $ val array
    1528      +*  mbacode = 8 **  $ m-achine b-lock a-rray (mba)
    1529      +*  eos_code = 9 **  $ code for end of subprogram
    1530
    1531
vax  127 .+s32.
vax  128      $   first, fields common to all header entries
vax  129      +*  vof_code = .e. 1,16, **  $  code of item
vax  130      +*  vof_hdrseq = .e. 17,16,  **  $ header sequence number
vax  131      +*  vof_es   = .e.33,16, **  $  entry size in bits
vax  132      +*  vof_lo   = .e.49,16, **  $ lo entry of array
vax  133      $   for debugging
vax  134      +*  vof_hi = .e.65,16, **  $ high entry of array
vax  135      +*  vof_listcode = .e. 81, 01, **  $ on to list generated code.
vax  136          $ to format of any item written to voa.
vax  137      +*  vof_hamax = .e. 97,16, **  $ hamax in gen
vax  138
vax  139      $   fields used to pass non/array args to assembler
vax  140      +*  vof_asmarg = .e. 129, 16,**  $ assemblarg
vax  141      +*  vof_init = .e. 145, 16,**  $ init
vax  142      +*  vof_lablistptr = .e. 161, 16, **  $  lablistptr
vax  143      +*  vof_sub1 = .e. 177, 16, **  $ subinfo(1), a name
vax  144      +*  vof_sub2 = .e. 193, 16,  **  $ subinfo(2)
vax  145      +*  vof_sub3 = .e. 209, 16, **  $ subinfo(3)
vax  146      +*  vof_subrargs = .e. 225, 16, ** $ no. of arguments of current
vax  147      $   routine
vax  148      +*  vof_ha0  = .e. 241, 16, ** $ ha index of constant 0.
vax  149      +*  vof_ha1  = .e. 113, 16, ** $ ha index of constant 1.
vax  150 ..s32
    1532 .+s37.
    1533      $   first, fields common to all header entries
    1534      +*  vof_code = .e. 1,16, **  $  code of item
    1535      +*  vof_hdrseq = .e. 17,16,  **  $ header sequence number
    1536      +*  vof_es   = .e.33,16, **  $  entry size in bits
    1537      +*  vof_lo   = .e.49,16, **  $ lo entry of array
    1538      $   for debugging
    1539      +*  vof_hi = .e.65,16, **  $ high entry of array
    1540      +*  vof_listcode = .e. 81, 01, **  $ on to list generated code.
    1541          $ to format of any item written to voa.
    1542      +*  vof_hamax = .e. 97,16, **  $ hamax in gen
    1543
    1544      $   fields used to pass non/array args to assembler
    1545      +*  vof_asmarg = .e. 129, 16,**  $ assemblarg
    1546      +*  vof_init = .e. 145, 16,**  $ init
    1547      +*  vof_lablistptr = .e. 161, 16, **  $  lablistptr
    1548      +*  vof_sub1 = .e. 177, 16, **  $ subinfo(1), a name
    1549      +*  vof_sub2 = .e. 193, 16,  **  $ subinfo(2)
    1550      +*  vof_sub3 = .e. 209, 16, **  $ subinfo(3)
    1551      +*  vof_subrargs = .e. 225, 16, ** $ no. of arguments of current
    1552      $   routine
    1553      +*  vof_ha0  = .e. 241, 16, ** $ ha index of constant 0.
    1554      +*  vof_ha1  = .e. 113, 16, ** $ ha index of constant 1.
    1555 ..s37
utsa 143 .+s47.
utsa 144      $   first, fields common to all header entries
utsa 145      +*  vof_code = .e. 1,16, **  $  code of item
utsa 146      +*  vof_hdrseq = .e. 17,16,  **  $ header sequence number
utsa 147      +*  vof_es   = .e.33,16, **  $  entry size in bits
utsa 148      +*  vof_lo   = .e.49,16, **  $ lo entry of array
utsa 149      $   for debugging
utsa 150      +*  vof_hi = .e.65,16, **  $ high entry of array
utsa 151      +*  vof_listcode = .e. 81, 01, **  $ on to list generated code.
utsa 152          $ to format of any item written to voa.
utsa 153      +*  vof_hamax = .e. 97,16, **  $ hamax in gen
utsa 154
utsa 155      $   fields used to pass non/array args to assembler
utsa 156      +*  vof_asmarg = .e. 129, 16,**  $ assemblarg
utsa 157      +*  vof_init = .e. 145, 16,**  $ init
utsa 158      +*  vof_lablistptr = .e. 161, 16, **  $  lablistptr
utsa 159      +*  vof_sub1 = .e. 177, 16, **  $ subinfo(1), a name
utsa 160      +*  vof_sub2 = .e. 193, 16,  **  $ subinfo(2)
utsa 161      +*  vof_sub3 = .e. 209, 16, **  $ subinfo(3)
utsa 162      +*  vof_subrargs = .e. 225, 16, ** $ no. of arguments of current
utsa 163      $   routine
utsa 164      +*  vof_ha0  = .e. 241, 16, ** $ ha index of constant 0.
utsa 165      +*  vof_ha1  = .e. 113, 16, ** $ ha index of constant 1.
utsa 166 ..s47
    1556 .+s66.
    1557      +*  vof_code = .e. 01, 06, **  $  code of item
    1558      +*  vof_hdrseq = .e. 07, 18, **  $ header sequence number.
    1559      +*  vof_es   = .e. 25, 12, **  $  entry size in bits
    1560      +*  vof_lo   = .e. 37, 12, **  $ lo entry of array
    1561      +*  vof_hi = .e. 49, 12, **  $ high entry of array
    1562      +*  vof_listcode = .e. 61, 01, **  $ on to list generated code.
    1563      +*  vof_hamax = .e. 62, 11, **  $ hamax in gen
    1564      +*  vof_asmarg = .e. 73, 12,**  $ assemblarg
    1565      +*  vof_init = .e. 85, 12,**  $ init
    1566      +*  vof_lablistptr = .e. 97, 12, **  $  lablistptr
    1567      +*  vof_sub1 = .e. 109, 12, **  $ subinfo(1), a name
    1568      +*  vof_sub2 = .e. 121, 12,  **  $ subinfo(2)
    1569      +*  vof_sub3 = .e. 133, 12, **  $ subinfo(3)
    1570      +*  vof_subrargs = .e. 145, 12, ** $ no. of arguments of current
    1571      $   routine
    1572      +*  vof_ha0  = .e. 157, 12, ** $ ha index of constant 0.
    1573      +*  vof_ha1  = .e. 169, 12, ** $ ha index of constant 1.
    1574 ..s66
    1575 .+s10.
    1576      +*  vof_code = .f. 1, 18, **
    1577      +*  vof_hdrseq = .f. 19, 18, **
    1578      +*  vof_es = .f. 37, 18, **
    1579      +*  vof_lo = .f. 55, 18, **
    1580      +*  vof_hi = .f. 73, 18, **
    1581      +*  vof_listcode = .f. 91, 1, **
    1582      +*  vof_hamax = .f. 109, 18, **
    1583      +*  vof_asmarg = .f. 127, 18, **
    1584      +*  vof_init = .f. 145, 18, **
    1585      +*  vof_lablistptr = .f. 163, 18, **
    1586      +*  vof_sub1 = .f. 181, 18, **
    1587      +*  vof_sub2 = .f. 199, 18, **
    1588      +*  vof_sub3 = .f. 217, 18, **
    1589      +*  vof_subrargs = .f. 235, 18, **
    1590      +*  vof_ha0 = .f. 253, 18, **
    1591      +*  vof_ha1 = .f. 271, 18, **
    1592 ..s10
    1593
    1594      size  vof(vofsz);  $ scratch area for building voa file frames.
    1595
    1596      size  vofhdrseq(ps);  data vofhdrseq=0;  $ vof header frame sequen
    1597      $   warnthis is number of warnings issued including current
    1598      $   routine.  warnprev is number of warnings issues through
    1599      $   end of previous routine.
    1600      size  warnprev(ps);  data warnprev = 0;
    1601      size  warnthis(ps);  data warnthis = 0;
    1602
    1603      $   x a r g.  extra arguments array
dsw   35      +*  xargsz =  $ size of xarg array.
dsw   36 .+s10    ws
dsw   37 .+s32    64
dsw   38 .+s37    64
utsa 167 .+s47    64
dsw   39 .+s66    ws
dsw   40          **
    1605      +*  xargmax = 511 **  $ xarg dims
    1606 .+s66    nameset blank;  $ keep in blank common on s66.
    1607      size  xarg(xargsz); dims xarg(xargmax);  $ extra arguments array
    1608 .+s66    end nameset;
    1609      size  xargptr(ps);  data xargptr = 1;   $ ptr to xarg
    1610      $   fields of xarg array
    1611 .+s66.
    1612      +*  xarg_voa = .f. 16, 15, **        $ ptr to voa entry
    1613      +*  xarg_db = .f. 31, 1, **
    1614      +*  xarg_rep = .f. 1, 15, **
    1615 ..s66
vax  151 .+s32.
vax  152      +*  xarg_voa = .f.  1, 16, **
vax  153      +*  xarg_db  = .f. 17,  1, **
dsw   41      +*  xarg_rep = .f. 33, 32, **
vax  155 ..s32
    1616 .+s37.
    1617      +*  xarg_voa = .f.  1, 16, **
    1618      +*  xarg_db  = .f. 17,  1, **
dsw   42      +*  xarg_rep = .f. 33, 32, **
    1620 ..s37
utsa 168 .+s47.
utsa 169      +*  xarg_voa = .f.  1, 16, **
utsa 170      +*  xarg_db  = .f. 17,  1, **
utsa 171      +*  xarg_rep = .f. 33, 32, **
utsa 172 ..s47
    1621 .+s10.
dsw   43      +*  xarg_voa = .f.  1, 15, **
dsw   44      +*  xarg_rep = .f. 19, 18, **
dsw   45      +*  xarg_db  = .f. 16,  1, **
    1625 ..s10
    1626
    1627      $   x h a. hash array for global symbols
    1628      +*  xhamax =   $ dimension of -xha-
    1629          443
    1630          **
    1631
    1632      +*  xhasz =  $ size of xha
    1633 .+s66   60
vax  156 .+s32   64
    1634 .+s37   64
utsa 173 .+s47   64
    1635 .+s10    72
    1636         **
    1637
    1638 .+s66    nameset blank;  $ keep in blank common on s66.
    1639      size  xha(xhasz); dims xha(xhamax);  $ global hash table
    1640 .+s66    end nameset;
    1641      $   xhafree is xha index of next free entry + 1.
    1642      size  xhafree(ps);  data xhafree = xhamax+1;
    1643
    1644      $   xha fields
    1645 .+s66.
    1646      +*  nlno     = .f. 01, 09, **  $ index of size info for global var
    1647      +*  xlink    = .f. 10, 09, **  $ link for hash in -xha-
    1648      +*  xnsblk   = .f. 19, 06, **  $ -mba- pointer for nameset
    1649      +*  xhabif   = .f. 25, 05, **  $ code if builtin operator name
    1650      +*  xnchars  = .f. 33, 08, **  $ number of characters of name
    1651      +*  xnameptr = .f. 41, 10, **  $ -xnames- index of symbol
    1652 ..s66
vax  157 .+s32.
vax  158      +*  nlno     = .f.  1, 16, **
vax  159      +*  xlink    = .f. 17, 16, **
vax  160      +*  xnsblk   = .f. 33,  8, **
vax  161      +*  xnchars  = .f. 41,  8, **
vax  162      +*  xhabif   = .f. 49,  6, **
vax  163      +*  xnameptr = .f. 55, 10, **
vax  164 ..s32
    1653 .+s37.
    1654      +*  nlno     = .f.  1, 16, **
    1655      +*  xlink    = .f. 17, 16, **
    1656      +*  xnsblk   = .f. 33,  8, **
    1657      +*  xnchars  = .f. 41,  8, **
    1658      +*  xhabif   = .f. 49,  6, **
    1659      +*  xnameptr = .f. 55, 10, **
    1660 ..s37
utsa 174 .+s47.
utsa 175      +*  nlno     = .f.  1, 16, **
utsa 176      +*  xlink    = .f. 17, 16, **
utsa 177      +*  xnsblk   = .f. 33,  8, **
utsa 178      +*  xnchars  = .f. 41,  8, **
utsa 179      +*  xhabif   = .f. 49,  6, **
utsa 180      +*  xnameptr = .f. 55, 10, **
utsa 181 ..s47
    1661 .+s10.
    1662      +*  nlno     = .f.  1, 18, **
    1663      +*  xlink    = .f. 19, 18, **
    1664      +*  xnameptr = .f. 37, 18, **
    1665      +*  xnsblk   = .f. 55,  6, **
    1666      +*  xhabif   = .f. 61,  5, **
    1667      +*  xnchars  = .f. 66,  7, **
    1668 ..s10
    1669
    1670      +*  xnamesmax = $ dimension of -xnames-
    1671 .+s66    400
vax  165 .+s32    600
    1672 .+s37    600
utsa 182 .+s47    600
dso   74 .+s10    600
    1674          **
    1675
    1676 .+s66    nameset blank;  $ keep in blank common on s66.
    1677      size  xnames(ws); dims xnames(xnamesmax);  $ xha names array
    1678 .+s66    end nameset;
    1679      size  xnamesptr(ps); data xnamesptr = 1;  $ xnames ptr
    1680
    1681
    1682
    1683      call genini;  $ to initialize program and print title
    1684      call parse;   $ enter parser
    1685      exitcode = 0; call genexit;  $ end executions (normal)
dso   75 .+s10    end prog start;
vax  166 .+s32    end prog start;
dso   76 .+s37    end prog start;
utsa 183 .+s47    end prog start;
dso   77 .+s66    end subr start;
       1 .=member  genini
       2      subr genini;  $  initialize parser
       3      size  help(sds(filenamelen)); data help = '';  $ initial debug opt
       4      size  machinename(sds(20)); $ names of possible host, targets
       5      dims  machinename(totmachines);
       6      data
ldsd  17      $   insert names of new machines after this line.
       8          machinename(m66) = 'cdc 6000 series':
ldsd  18 .+s32v   machinename(m32) = 'dec vax-11 vms':
ldsd  19 .+s32u   machinename(m32) = 'dec vax-11 unix':
dso   78          machinename(m37) = 'ibm system/370':
utsa 184          machinename(m47) = 'amdahl uts':
dso   79          machinename(m40) = 'prime 400':
      10          machinename(m16) = 'honeywell series 16':
      11          machinename(m11) = 'dec pdp-11':
      12          machinename(m10) = 'decsystem-10';
      13
      14      size  tmvar(sds(10)); $ receives tm specification
      15      $   --note-- require that filenamelen >= 2*tmparams
      16      size  tmvarlabel(sds(35));
      17      size  c1(cs), c2(cs);  $ character temporaries for tm processing
      18      data  tmvarlabel = ' ws=  , ps=  , cs=  , sl=  , so=  .';
      19      size  voafilename(sds(filenamelen)); $ name of voa file
      20      size  tokenfilename(sds(filenamelen)); $ name of token file
dsv   16      size  appstr(.sds. getapp_len);  $ actual parameter string.
      22      size  i(ps);  $ do loop index
      23      size  j(ps);            $ index.
      24      size  hap(ps), xhap(ps);  $ ha and xha indexes.
ldsa  55      size  rep_opt_str(.sds. filenamelen);
eaa    9      size  targetmachine20(1);  $ on if tm=20 for extended addr.
      25
      26      do  i = 1 to xhamax;  xha(i) = 0;  end do; $ clear xha.
      27      $   we hold the alias names for built-in functions in -bfntab-
      28      $   during initialization in the flollowing format (op, name).
      29      $   if op is zero, name is the machine for which the aliases are
      30      $   assigned (0 ends list).
dss   35      +*  bfntabsz = (.sds. 10) **
utsa 185      +*  bfntabmax = 150 **
      33      size  bfntab(bfntabsz);  dims bfntab(bfntabmax);
      34      data  bfntab =
      35      +*  ins(op, name) = op, name, **  $ name to insert
dso   81          0, m10,      $ aliases for s10
dso   87          ins(bop_exp,    'expx$r')
dso   88          ins(bop_alog,   'alog$r')
dso   89          ins(bop_alog10, 'al10$r')
dso   90          ins(bop_sin,    'sinx$r')
dso   91          ins(bop_cos,    'cosx$r')
dso   92          ins(bop_tanh,   'tanh$r')
dso   93          ins(bop_sqrt,   'sqrt$r')
dso   94          ins(bop_atan,   'atan$r')
dso   95          ins(bop_atan2,  'atn2$r')
vax  169          0, m32,      $ aliases for s32
dss   36          ins(bop_exp,    'mth$exp')
dss   37          ins(bop_alog,   'mth$alog')
ldsb  22 .+s32v   ins(bop_alog10, 'mth$alog10')
ldsb  23 .+s32u   ins(bop_alog10, 'mth$alg10')  $ at most eight chars for unix
dss   39          ins(bop_sin,    'mth$sin')
dss   40          ins(bop_cos,    'mth$cos')
dss   41          ins(bop_tanh,   'mth$tanh')
dss   42          ins(bop_sqrt,   'mth$sqrt')
dss   43          ins(bop_atan,   'mth$atan')
ldsb  24 .+s32v   ins(bop_atan2,  'mth$atan2')
ldsb  25 .+s32u   ins(bop_atan2,  'mth$atn2')  $ at most eight chars for unix
ldsd  20          ins(bop_amod,   'mth$amod')
ldsd  21          ins(bop_aint,   'mth$aint')
ldsd  22          ins(bop_dim,    'mth$dim')
      36          0, m37,      $ aliases for s37
      37          ins(bop_float,  'fltc$rl')
      38          ins(bop_ifix,   'ifix$rl')
      39          ins(bop_aint,   'aint$rl')
      40          ins(bop_int,    'ifix$rl')
      41          ins(bop_amod,   'amod$rl')
      42          ins(bop_exp,    'expx$rl')
      43          ins(bop_alog,   'alog$rl')
      44          ins(bop_alog10, 'al10$rl')
      45          ins(bop_sin,    'sinx$rl')
      46          ins(bop_cos,    'cosx$rl')
      47          ins(bop_tanh,   'tanh$rl')
      48          ins(bop_sqrt,   'sqrt$rl')
      49          ins(bop_atan,   'atan$rl')
      50          ins(bop_atan2,  'atn2$rl')
utsa 186          0, m47,      $ aliases for s47
utsa 187 $    these names must match those used in little env mlib.s to
utsa 188 $    interface to the c library.
utsa 189          ins(bop_float,  'fltc$rl')
utsa 190          ins(bop_ifix,   'ifix$rl')
utsa 191          ins(bop_aint,   'aint$rl')
utsa 192          ins(bop_int,    'ifix$rl')
utsa 193          ins(bop_amod,   'amod$rl')
utsa 194          ins(bop_exp,    'expx$rl')
utsa 195          ins(bop_alog,   'alog$rl')
utsa 196          ins(bop_alog10, 'al10$rl')
utsa 197          ins(bop_sin,    'sinx$rl')
utsa 198          ins(bop_cos,    'cosx$rl')
utsa 199          ins(bop_tanh,   'tanh$rl')
utsa 200          ins(bop_sqrt,   'sqrt$rl')
utsa 201          ins(bop_atan,   'atan$rl')
utsa 202          ins(bop_atan2,  'atn2$rl')
      51          0,m66,   $ aliases for 6600.
      52          ins(bop_exp   ,'expx$ml')
      53          ins(bop_alog  ,'alog$ml')
      54          ins(bop_alog10,'al10$ml')
      55          ins(bop_sin   ,'sinx$ml')
      56          ins(bop_cos   ,'cosx$ml')
      57          ins(bop_tanh  ,'tanh$ml')
      58          ins(bop_sqrt  ,'sqrt$ml')
      59          ins(bop_atan  ,'atan$ml')
      60          ins(bop_atan2 ,'atn2$ml')
      61          0, 0;    $ end of alias list
      62      macdrop(ins)
      63
      64      size  wpr(ps);  data wpr = 1;  $ words per real.
      65
      66      $   initialization data for built-ins
      67      size  bfnames(sds(6)); dims bfnames(numfncts);
      68      data  bfnames = $ user names for built-in functions
      69          'float',  'ifix',   'abs',    'iabs',   'aint',   'int',
      70          'amod',   'mod',    'sign',   'isign',  'dim',    'idim',
      71          'exp',    'alog',   'alog10', 'sin',    'cos',    'tanh',
      72          'sqrt',   'atan',   'atan2';
      73
      74      $   the -bftyptab- array contains bit strings (one for each target
      75      $   machine) indicating the types of each function.  if a bit is
      76      $   1, the corresponding function is external; otherwise it is
      77      $   internal.
      78      size  bftyptab(numfncts); dims bftyptab(totmachines);
      79      data
dsr   14          bftyptab(m10) = 1b' 1 11111 11100 00000 00000':
      81          bftyptab(m11) = 1b' 1 11111 11101 01011 10111':
      82          bftyptab(m16) = 1b' 1 11111 11100 00000 00000':
ldsd  23          bftyptab(m32) = 1b' 1 11111 11101 00010 10000':
      83          bftyptab(m37) = 1b' 1 11111 11100 00011 10011':
utsa 203          bftyptab(m47) = 1b' 1 11111 11100 00011 10011':
dso   96          bftyptab(m40) = 1b' 1 11111 11100 00011 10011':
      84          bftyptab(m66) = 1b' 1 11111 11100 00000 00000';
      85
      86      sorg sdsnamstr = nameorg;  $ initalize origin
      87
      88      $   on entry, the literal information is available in arglist
      89      $   as 3 entry groups, giving literal code, class, and value.
      90      $   a code of 0 indicates end of list.
      91      size  cc(ps), vv(ps);
      92      do  i = 1 to argmax;  $ scan over initial data.
      93          if  (arglist(i) = 0) quit do;  $ at end of table.
      94          vv = .f. 9, 8, arglist(i);  $ get value.
      95          if  .f. 1, 8, arglist(i) then  $ if table entry.
      96              littabl(cc, (.f. 1, 8, arglist(i))) = vv;  $ set value.
      97          else
      98              cc = vv;  $ set class
      99              end if;
     100          end do;
     101
     102      do  i = 1 to hamax;  $ clear the ha.
     103          ha(i) = 0;  end do;
     104
     105      i = 0;  $ set to null tm
vax  184 .+s32    call getipp(i, 'tm=32/11');
     106 .+s37    call getipp(i, 'tm=37/');
utsa 204 .+s47    call getipp(i, 'tm=47/');
     107 .+s66    call getipp(i, 'tm=66/');
     108 .+s10    call getipp(i, 'tm=10/');
eaa   10      targetmachine20 = no;  $ assume not tm=20
     109      $   convert supplied code to machine code value.
     110      if      i=66  then  targetmachine = m66;
     111      elseif  i=37  then  targetmachine = m37;
dso   97      elseif  i=40  then  targetmachine = m40;
     112      elseif  i=16  then  targetmachine = m16;
     113      elseif  i=11  then  targetmachine = m11;
     114      elseif  i=10  then  targetmachine = m10;
eaa   11      elseif  i=20  then  targetmachine = m10;
eaa   12          targetmachine20 = yes; $ note so can set .ps. correctly.
vax  185      elseif  i=32  then  targetmachine = m32;
utsa 205      elseif  i=47  then  targetmachine = m47;
     115      else    targetmachine = hostmachine;
     116          end if;
     117
     118      do  i = 1 to numfncts;
     119          bfmode bifatrtab(i) =
     120              (.ch. 1, bfnames(i) < 1ri ! .ch. 1, bfnames(i) > 1rn);
     121          bfext bifatrtab(i) = .f. i, 1, bftyptab(targetmachine);
     122          bfargs bifatrtab(i) = blkendtype(opofbif(i))-1;
     123          call pshnamr(hap, bfnames(i)); $ add name to -ha-
     124          insglob(xhap, hap);  $ and then to -xha-
     125          xhabif xha(xhap) = i;  $ mark as builtin
     126          end do;
     127
     128      $   now, check for any alias names for this machine.
     129
     130      $   first, look for marker for machine.
     131      do  i = 1 to bfntabmax by 2;  $ names kept in -bfntab-
     132          if  .f. 1, ws, bfntab(i) = 0 then  $ we have a marker
     133              if  (.f. 1, ws, bfntab(i+1) = 0) quit do; $ hit end of tab
     134              if  .f. 1, ws, bfntab(i+1) = targetmachine then $ got it
     135                  do  j = i+2 to bfntabmax by 2;
     136                      if  (.f. 1, ws, bfntab(j) = 0) quit do;
     137                      call pshnamr(hap, bfntab(j+1)); $ add to -ha-
     138                      insglob(xhap, hap);  $ then to -xha-
     139                      bfalias bifatrtab(bifofop((.f. 1, ws, bfntab(j))))
     140                          = xhap;
     141                      end do;
     142                  end if;
     143              end if;
     144          end do;
     145 .+pt call getipp(parsetrace, 'pt=0/1');
     146
utsa 206 .+s37. $ see if want ebcdic/ascii conversion
utsa 207      call getipp(ebcascoption,'ebcasc=0/1');
utsa 208 ..s37
utsa 209
     147      call getipp(asmvoadump, 'ad=0/1');
     148      tmvar = tmvardef;
     149
     150      if  targetmachine = m16  then $ honeywell series 16
     151          tmvar = '1616081616';  iorts='';
     152          wpr = 2;  $ two words for floating point on s16.
     153      elseif  targetmachine = m11  then  $ pdp-11.
     154          tmvar = '1615081616';
     155      elseif  targetmachine = m37  then
utsa 210          tmvar = '3224081616';
utsa 211      elseif  targetmachine = m47  then
utsa 212          tmvar = '3224081616';
dso   98      elseif  targetmachine = m40  then
dso   99          tmvar = '1615081616';
     157      elseif  targetmachine = m66  then
     158          tmvar = '6017061113';
     159      elseif  targetmachine = m10 then
mgfb  15          tmvar = '3618091818';
vax  186      elseif  targetmachine = m32 then
vax  187          tmvar = '3230081616';
     161          end if;
eaa   13
eaa   14      if  targetmachine20 then $ if extended addressing
eaa   15          tmvar = '3630091818'; $ s10, except ps=30
eaa   16          end if;
     162
     163      if  targetmachine = hostmachine  then
     164          do  i = 1 to toktypes;
     165              safeconst(i) = yes;  end do;
     166          end if;
     167
utsa 213
utsa 214 .+s37.  $ safe to convert also if target is s47
utsa 215      if targetmachine = m47 then
utsa 216          do  i = 1 to toktypes;
utsa 217              safeconst(i) = yes; end do;
utsa 218          end if;
utsa 219 ..s37
utsa 220
     168      $  bit constants may always be converted safely.
     169      safeconst(dectok) = yes;  safeconst(bittok) = yes;
     170      safeconst(sstok) = no;   $ s-type strings are never safe.
     171
     172      call getspp(tmvar, 'tmp=' !! tmvar !! '/');
     173      if  (slen tmvar ^= 10) tmvar = tmvardef;  $ set default.
     174
     175      do  i = 1 to 5;
     176          c1 = .ch.(i*2)-1, tmvar; c2 = .ch. i*2, tmvar;
     177          tmara(i) = 10*digofchar(c1) + digofchar(c2);
     178          .ch. i*7 - 2, tmvarlabel = c1;
     179          .ch. i*7 - 1, tmvarlabel = c2;
     180          tmtokara(i) = blankword;
     181          .f. tokarasz+1 - 1*cs, cs, tmtokara(i) = c1;
     182          .f. tokarasz+1 - 2*cs, cs, tmtokara(i) = c2;
     183          end do;
     184
     185      rlsz = mws * wpr;  $ size of real number.
     186
     187      call getipp(sfp_opt, 'sfp=0/1');
     188
     189      gsopt = 1;  $ for now, by default first procedure defines nameset
     190      daopt = 1;  $ for now, each routine has default access to all name
     191      $   sets
     192      call getipp(gsopt, 'gs=1/0');
     193      call getipp(daopt, 'da=1/0');
     194
ldse  13      call getipp(expire, 'expire=0/366');
ldse  14
vax  188 .+s32    call getspp(tokenfilename, 'tokens=tokens.tmp/');
     195 .+s37    call getspp(tokenfilename, 'tokens=sysut1/');
utsa 221 .+s47    call getspp(tokenfilename, 'tokens=sysut1/');
     196 .+s66    call getspp(tokenfilename, 'tokens=tokens/');
mgfa   1 .+s10    call getspp(tokenfilename, 'tokens=*.tok/');
     198      call opensio(tokenfile, iorc, access_read, tokenfilename,
     199          0, i, 0, 0);
dsv   17 .+s66   call rewisio(tokenfile, iorc, 0);
     201      call dropsio(tokenfile, iorc);  $ this is terminal use of tokenfil
     202      call rdrwsio(tokenfile, iorc, tokrbuf, 1, tokrbuflim);
vax  189 .+s32    call getspp(voafilename, 'voa=voa.tmp/');
     203 .+s37    call getspp(voafilename, 'voa=sysut2/');
utsa 222 .+s47    call getspp(voafilename, 'voa=sysut2/');
     204 .+s66    call getspp(voafilename, 'voa=voa/');
mgfa   2 .+s10    call getspp(voafilename, 'voa=*.voa/');
     206      voawrt = (.ch. 1, voafilename ^= 1r0);  $ set whether writing voa
     207          file voafile access=write, title=voafilename;
dsv   18 .+s66       rewind voafile;
     209      $   now write frame marking start of file
     210          vof = 0;
     211          vof_code  vof = voahdr_code;  $ file header
dspp   1 .+s66    voa_level vof = voafilelevel;
     213      $   other fields not defined now
     214          vofhdrseq = vofhdrseq+1;  vof_hdrseq vof = vofhdrseq;
     215          write voafile, vof;
     216
     221      call getipp(pelvalue, 'pel=50/10000');
     222      call getipp(proclist, 'pdir=0/1');
     223
dso  101 .+s10    call getspp(crfileparm, 'rf=*.rf0/');
vax  191 .+s32    call getspp(crfileparm, 'rf=little.rf0/');
     224 .+s37    call getspp(crfileparm, 'rf=sysref(ref0)/');
utsa 223 .+s47    call getspp(crfileparm, 'rf=sysref(ref0)/');
     225 .+s66    call getspp(crfileparm, 'rf=ref0/');
     230      call getipp(crossrefoption, 'lcr=0/1');
dsu   10      $   pdir option requires crossrefoption.
dsu   11      if  (proclist)  crossrefoption = yes;
     231      if  crossrefoption  then  $ open second reference file.
     232          proclist = yes;  $ get procedure directory.
     233          call crfnam(crfilename, crfileparm, 3); $ file 3.
     234          call opensio(crfile, iorc, access_write, crfilename,
     235              0, i, 0, 0);
     236          end if;
     237      mbaptr = globalblock - 1;  $ mbaptr points to last global block
     238      $   that has been defined, so start  off just below globalblock
     239
     240
ldsa  56 .+rep.
ldsa  57      call getspp(rep_opt_str, 'rep=0/pg');
ldsa  58      rep_opt_c = ('c' .in. rep_opt_str) > 0;
ldsa  59      rep_opt_g = ('g' .in. rep_opt_str) > 0;
ldsa  60      rep_opt_p = ('p' .in. rep_opt_str) > 0;
ldsa  61      rep_opt = rep_opt_c ! rep_opt_g ! rep_opt_p;
ldsa  62      if rep_opt then
ldsa  63          file repfile access=put,title='', linesize=80;
ldsa  64          end if;
ldsa  65 ..rep
     241      call getipp(ncfopt, 'ncf=1/0');
     242 .+s66.   $   set ncfopt=0 as default for bootstrap from
     243          $   s66 to s10.
dso  102      $   disable ncf by default if bootstrapping from s66.
vax  192      if  targetmachine=m10 ! targetmachine=m32
vax  193          ! targetmachine=m40  then
dso  104          call getipp(ncfopt, 'ncf=0/1');  end if;
     245 ..s66
     246      call getipp(debuglevel, 'mlev=1/2');
     247      call getspp(help, 'help=/es');
     248      if  ('0' .in. help) help = '';  $ if '0' anywhere, no options used
     249      if  (slen help) debuglevel = 2;  $ set debug level
     250      gtrentrfg = ('e' .in. help) ^= 0;  $ set global debug flags
     251      gtrstorfg = ('s' .in. help) ^= 0;
     252      gtrflowfg = ('f' .in. help) ^= 0;
     253      gchinxfg  = ('c' .in. help) ^= 0;
     254
     255
meal  14      $   if trace entry in effect, arguments to procedure will be
meal  15      $   listed if value of trentrargs nonzero; otherwise, only
meal  16      $   procedure name will be listed.
meal  17      call getipp(trentrargs,'meal=1/0');
meal  18      if  (trentrargs>1)  trentrargs = 1;
     256
     257      size  sl(ps);  $ length of iorts
     258      sl = slen iorts;
     259      do  i = 1 to ionamesptr;
     260          if  sl  then $ non-null trailer, append it
     261              slen ionames(i) = 4+sl; $ adjust length
     262              .s. 5, sl, ionames(i) = iorts; $ append trailer
     263          else  $ null trailer, adjust length to 4
     264              slen ionames(i) = 4;
     265              end if;
     266          end do  i;
     267
     268      sl = slen dbgts;
     269      do  i = 1 to numdebugnames;
     270          if  sl then  $ non-null trailer string, append it
     271              slen debugnames(i) = 4+sl;  $ adjust length
     272              .s. 5, sl, debugnames(i) = dbgts;  $ append trailer
     273          else  $ null trailer, adjust length
     274              slen debugnames(i) = 4;
     275              end if;
     276          end do i;
     277      call getipp(lcs_opt, 'lcs=1/0');  $ list compilation statistics.
     278      call getipp(lcp_opt, 'lcp=1/0');  $ list compilation parameters.
utse  14 .+s32u.  $ minimal listing by default for unix.
ldsb  27      call getipp(lcp_opt, 'lcp=0/1');
ldsb  28      call getipp(lcs_opt, 'lcs=0/1');
utse  15 ..s32u
utse  16 .+s47.  $ minimal listing by default for unix.
utse  17      call getipp(lcp_opt, 'lcp=0/1');
utse  18      call getipp(lcs_opt, 'lcs=0/1');
utse  19 ..s47
     279
dsv   19      $   get actual parameters specified.
dsv   20      call getapp(appstr, getapp_len);
dsv   21
dss   45 .+s10    call getipp(cis_opt, 'cis=0/18');
dss   46 .+s32    call getipp(cis_opt, 'cis=0/30');
dss   47 .+s37    call getipp(cis_opt, 'cis=0/24');
utsa 224 .+s47    call getipp(cis_opt, 'cis=0/24');
dss   48 .+s66    call getipp(cis_opt, 'cis=0/17');
     280      call ltitlr(compilerlevel);
     281      call stitlr(0, 'little compilation - parse phase.');
ldsc  11      if  (lcp_opt=0)  go to parmslisted;
     283      $   remaining code lists compilation parameters.
     284
     285      call stitlr(1, 'parameters for this parse.');
     286
dsv   22      if  .len. appstr  then $ if any explicitly specified.
dsv   23          textl(appstr)  endl endl
dsv   24          end if;
dsv   25
     287      textl('host machine = ') textl(machinename(hostmachine))
     288      textl('.  target machine: tm = ')
     289      textl(machinename(targetmachine))
     290      textl('.')  endl
     291
     292      textl('target machine parameters: tmp = ')
     293      textl(tmvarlabel)
     294      endl
     295
     296      textl('parse error limit: pel =') intlp(pelvalue, 3)
     297      textl('.  asm voa dump: ad =') intlp(asmvoadump, 2)
     298      textl('.') endl
     299
     300      textl('globals in start: gs =') intlp(gsopt, 2)
     301      textl('.  default access: da =')  intlp(daopt, 2)
     302      textl('.')  endl
     303
     304      if  slen help then  $ output initial debug options
     305          textl('initial debug options: help =')
     306          textl(help) textl('.  ')
     307          end if;
     308
     309      textl('monitor level: mlev =') intlp(debuglevel, 2)
meal  19      textl('.  monitor entry arg list: meal=') intlp(trentrargs, 2)
meal  20      textl('.')  endl
     311
     312      textl('list statistics: lcs =')  intlp(lcs_opt,2)
     313      textl('.  fold negative constants: ncf =')  intlp(ncfopt, 2)
     314      textl('.')  endl
     315
     316      textl('voa file: voa = ') textl(voafilename)
     317      textl('.  suppress first procedure: sfp =')  intlp(sfp_opt, 2)
     318      textl('.')  endl
     319      textl('lexical cross reference list: lcr =')
     320      intlp(crossrefoption,2)
     321      textl('.  reference file: rf = ') textl(crfileparm)
     322      textl('.') endl
     323
     324      textl('list procedure directory: pdir =') intlp(proclist, 2)
dss   49      textl('.  check index size: cis =')  intlp(cis_opt,3)
     325      textl('.') endl
ldse  15      if  expire  then  $ only list if expire specified.
ldse  16          textl('expire: expire = ') intl(expire) textl('.') endl
ldse  17          end if;
     326      endl
utsa 225 .+s37.
utsa 226      textl('ebcdic to ascii: ebcasc = ') intl(ebcascoption) textl('.')
utsa 227      endl
utsa 228 ..s37
     327      endl
     328
ldsc  12 /parmslisted/
     329      call stitlr(1, 'program listing.');  $ set subtitle
     330
     331      call ptdata;  call purge;  $ initialize.
     332
     333      end subr genini;
       1 .=member  ptdata
       2      subr ptdata;  $ data for parse table (pt)
       3      nameset pt;
       4      size  pt(32);
       5      dims  pt(ptmax);
       6      end nameset;
       7      data pt =
       8 $ member syntab
       9      4b'001c 1295', 4b'04a5 0895', 4b'0905 0975', 4b'0b75 0b95', $   1
      10      4b'0c55 0d85', 4b'0eb5 0015', 4b'1155 1195', 4b'11e5 0bc5', $   2
      11      4b'01a5 01f5', 4b'0335 0155', 4b'005b 0011', 4b'0016 04f3', $   3
      12      4b'0245 000b', 4b'0011 0016', 4b'0583 0245', 4b'001b 0011', $   4
      13      4b'0016 03a3', 4b'0245 002b', 4b'0011 0437', 4b'0305 0016', $   5
      14      4b'0593 0459', 4b'0447 0173', 4b'003b 0011', 4b'2a55 004b', $   6
      15      4b'0011 2a55', 4b'0016 0143', 4b'0437 0405', 4b'2bca 0113', $   7
      16      4b'0447 0123', 4b'001b 0021', 4b'0357 0133', 4b'0015 01cb', $   8
      17      4b'0031 0357', 4b'0133 0015', 4b'0457 0002', 4b'0016 04e3', $   9
      18      4b'0002 001b', 4b'0041 2a8a', 4b'04a3 0477', 4b'0535 002b', $  10
      19      4b'0041 0015', 4b'0197 0585', 4b'00ab 0041', 4b'2a55 0187', $  11
      20      4b'05d5 00bb', 4b'0041 2a55', 4b'0177 0705', 4b'0207 0423', $  12
      21      4b'0016 0433', 4b'0437 0775', 4b'2a8a 0403', 4b'0447 0413', $  13
      22      4b'00d6 07a5', 4b'00a7 07a5', 4b'009b 0041', 4b'0015 003b', $  14
      23      4b'0041 12ca', 4b'0103 004b', 4b'0041 2a55', 4b'006b 0041', $  15
      24      4b'2a55 003b', 4b'0041 0127', 4b'03c3 2bca', 4b'03e3 0207', $  16
      25      4b'03d3 2bca', 4b'03f3 003b', 4b'0021 004b', 4b'0041 0002', $  17
      26      4b'001b 0051', 4b'2a8a 0643', 4b'002b 0051', 4b'2a55 001b', $  18
      27      4b'0061 2a8a', 4b'05b3 002b', 4b'0061 2a55', 4b'001b 0071', $  19
      28      4b'0016 02f3', 4b'02e7 02c3', 4b'2a8a 02d3', 4b'0207 02b3', $  20
      29      4b'2a8a 02e3', 4b'0487 0a85', 4b'0aba 0303', 4b'2a55 002b', $  21
      30      4b'0071 2a55', 4b'0337 0b25', 4b'2a8a 0002', 4b'003b 0071', $  22
      31      4b'0002 2a8a', 4b'0002 004b', 4b'0071 0002', 4b'0081 2a55', $  23
      32      4b'005b 0041', 4b'0015 007b', 4b'0041 2a8a', 4b'0323 0477', $  24
      33      4b'0313 008b', 4b'0041 0015', 4b'0c9a 0563', 4b'0d39 2a55', $  25
      34      4b'0016 0002', 4b'0437 0553', 4b'2bca 0543', 4b'0447 0573', $  26
      35      4b'0091 0002', 4b'0457 0002', 4b'0c9a 0563', 4b'0002 0dca', $  27
      36      4b'0293 0e69', 4b'2a55 0016', 4b'0002 0437', 4b'0283 2bca', $  28
      37      4b'0273 0447', 4b'02a3 00a1', 4b'0002 0457', 4b'0002 0dca', $  29
      38      4b'0293 0002', 4b'0016 0223', 4b'0437 0f65', 4b'2bca 0233', $  30
      39      4b'0447 0243', 4b'001b 00b1', 4b'0f95 002b', 4b'00b1 0f95', $  31
      40      4b'02e7 0203', 4b'103a 0213', 4b'1109 004b', 4b'00b1 0467', $  32
      41      4b'2a55 0eb5', 4b'2b7a 0002', 4b'0437 10e5', 4b'2bca 0253', $  33
      42      4b'0447 0263', 4b'003b 00b1', 4b'0002 0088', 4b'0002 0457', $  34
      43      4b'0002 103a', 4b'0333 0002', 4b'0016 04d3', 4b'00c1 2a55', $  35
      44      4b'0016 0183', 4b'0459 00d1', 4b'2a55 0016', 4b'0523 00e1', $  36
      45      4b'1239 2a55', 4b'0457 0002', 4b'0016 0523', 4b'00e1 0002', $  37
      46      4b'12ca 0103', 4b'2a55 002c', 4b'1b95 1455', 4b'15a5 16d5', $  38
      47      4b'1705 18f5', 4b'1935 1965', 4b'1985 19a5', 4b'19c5 1d05', $  39
      48      4b'1d75 2435', 4b'25a5 1b35', 4b'1de5 1e75', 4b'25f5 2615', $  40
      49      4b'26d5 26f5', 4b'2875 28e5', 4b'0016 01c3', 4b'0437 1515', $  41
      50      4b'2a8a 01d3', 4b'1559 0447', 4b'01e3 002b', 4b'00f1 0002', $  42
      51      4b'0088 001b', 4b'00f1 0002', 4b'0457 0002', 4b'2a8a 0333', $  43
      52      4b'0002 0437', 4b'1615 2a8a', 4b'0443 0447', 4b'0453 1645', $  44
      53      4b'0016 0483', 4b'1645 0437', 4b'0473 0016', 4b'0463 0459', $  45
      54      4b'0447 0493', 4b'0101 0002', 4b'0111 0088', 4b'0002 0207', $  46
      55      4b'0423 0016', 4b'0433 0437', 4b'1855 2a8a', 4b'0403 0447', $  47
      56      4b'0413 0127', 4b'1895 2bca', 4b'03e3 0207', 4b'03d3 2bca', $  48
      57      4b'03f3 003b', 4b'0021 0002', 4b'0088 01db', 4b'0031 0002', $  49
      58      4b'00d8 0121', 4b'0088 002b', 4b'0021 0002', 4b'000b 0131', $  50
      59      4b'0088 0002', 4b'0141 0088', 4b'0002 0168', 4b'1a65 01e8', $  51
      60      4b'1a65 0268', 4b'1a65 02e8', 4b'2a8a 0673', 4b'0457 0663', $  52
      61      4b'1bda 05e3', 4b'1caa 05c3', 4b'0002 2a8a', 4b'0673 0457', $  53
      62      4b'0663 2a8a', 4b'0673 0457', 4b'0663 1bda', 4b'05e3 1caa', $  54
      63      4b'05c3 0002', 4b'0368 1bda', 4b'05e3 1caa', 4b'05c3 0002', $  55
      64      4b'1bda 00e3', 4b'00e8 1ca5', 4b'0016 0002', 4b'0437 1c75', $  56
      65      4b'2a8a 0633', 4b'0447 0623', 4b'00c8 0002', 4b'0088 0048', $  57
      66      4b'0002 02e7', 4b'0002 2a8a', 4b'05d3 0151', 4b'0002 001b', $  58
      67      4b'0161 1f0a', 4b'0002 20ba', 4b'03b3 0002', 4b'002b 0161', $  59
      68      4b'1f0a 0002', 4b'20ba 0503', 4b'0002 2a8a', 4b'0513 00bb', $  60
      69      4b'0161 206a', 4b'0073 2069', 4b'0171 0002', 4b'2a8a 0653', $  61
      70      4b'00cb 0161', 4b'206a 0073', 4b'2069 0171', 4b'0002 2a8a', $  62
      71      4b'1f55 003b', 4b'0161 0002', 4b'0088 004b', 4b'0161 0002', $  63
      72      4b'2a8a 0002', 4b'0207 2025', 4b'2a8a 05f3', 4b'002b 0181', $  64
      73      4b'0002 0088', 4b'001b 0181', 4b'0002 0457', 4b'0002 1f9a', $  65
      74      4b'0073 0002', 4b'006b 0161', 4b'211a 0002', 4b'2119 0002', $  66
      75      4b'220a 2145', 4b'0002 21ba', 4b'0002 21b9', 4b'231a 0063', $  67
      76      4b'0171 0002', 4b'0467 0002', 4b'1f9a 0073', 4b'0002 0457', $  68
      77      4b'0002 0036', 4b'0043 0437', 4b'22d5 2a8a', 4b'0093 0447', $  69
      78      4b'00c3 001b', 4b'0191 0002', 4b'0088 000b', 4b'0191 0002', $  70
      79      4b'0457 0002', 4b'0046 0053', 4b'0437 23f5', 4b'2a8a 0093', $  71
      80      4b'1559 0447', 4b'00c3 001b', 4b'01a1 0002', 4b'0088 000b', $  72
      81      4b'01a1 0002', 4b'2a8a 0343', 4b'007b 0161', 4b'24ca 00a3', $  73
      82      4b'2559 01b1', 4b'0002 0056', 4b'0002 02e7', 4b'01a3 2a8a', $  74
      83      4b'01b3 008b', 4b'0161 0002', 4b'0457 0002', 4b'24ca 00a3', $  75
      84      4b'0002 2a8a', 4b'0533 009b', 4b'0161 0002', 4b'00b8 2635', $  76
      85      4b'0138 2635', 4b'0497 01f3', 4b'0016 26a5', 4b'0459 01c1', $  77
      86      4b'0002 0088', 4b'01d1 0002', 4b'00b8 2715', 4b'0038 2715', $  78
      87      4b'27ba 05a3', 4b'0016 2785', 4b'0459 01e1', 4b'0002 0088', $  79
      88      4b'01f1 0002', 4b'04a7 27f5', 4b'00a8 0002', 4b'04b7 2835', $  80
      89      4b'01a8 0002', 4b'04c7 0002', 4b'02a8 0002', 4b'000b 0201', $  81
      90      4b'2a8a 0193', 4b'001b 0201', 4b'0002 0211', 4b'299a 00b3', $  82
      91      4b'2949 0221', 4b'0002 0457', 4b'0002 299a', 4b'00b3 0002', $  83
      92      4b'05c7 2a15', 4b'02e7 04b3', 4b'2a8a 04c3', 4b'0231 0002', $  84
      93      4b'0076 0002', 4b'0241 0002', 4b'00a7 00d3', 4b'0015 0096', $  85
      94      4b'2b05 00a6', 4b'2c15 000e', 4b'2dc9 000f', 4b'0002 000e', $  86
      95      4b'2d0a 2b55', 4b'000f 0002', 4b'000f 0002', 4b'2a8a 0002', $  87
      96      4b'0058 0121', 4b'0002 2a8a', 4b'0002 00d8', 4b'0121 0002', $  88
      97      4b'2a8a 0603', 4b'1559 0447', 4b'0613 003b', 4b'00f1 00a6', $  89
      98      4b'2ce5 000e', 4b'2dc9 000f', 4b'0002 0251', 4b'0002 2e2a', $  90
      99      4b'2d45 2dc9', 4b'0002 00f6', 4b'0002 2e2a', 4b'00f3 2dc9', $  91
     100      4b'002d 2dc9', 4b'0002 00e6', 4b'0002 2d0a', 4b'0083 001d', $  92
     101      4b'0002 00b6', 4b'0002 00c6', 4b'0002 2fa5', 4b'3025 3085', $  93
     102      4b'30e5 3145', 4b'3295 2ed5', 4b'0437 0383', 4b'2a8a 0363', $  94
     103      4b'0457 0353', 4b'0066 0373', 4b'0447 0393', 4b'00ab 0161', $  95
     104      4b'0002 2a8a', 4b'0603 1559', 4b'0447 0613', 4b'003b 00f1', $  96
     105      4b'0002 0128', 4b'31ea 0002', 4b'01ab 0261', 4b'0002 01a8', $  97
     106      4b'31ea 0002', 4b'025b 0261', 4b'0002 0228', 4b'31ea 0002', $  98
     107      4b'026b 0261', 4b'0002 02a8', 4b'2a8a 0033', 4b'0457 0023', $  99
     108      4b'2e2a 0013', 4b'001b 0261', 4b'0002 2a8a', 4b'0033 0457', $ 100
     109      4b'0023 2a8a', 4b'0033 0457', 4b'0023 2e2a', 4b'0013 0002', $ 101
     110      4b'2a8a 0153', 4b'0447 0163', 4b'0002 0271', 4b'3305 0086', $ 102
     111      4b'2a55 3305' ;                                             $ 103
     112 $ end member syntab
     113
     114      $   macros for packed format of parse table.
     115      +*  opt_op   = .f. 1,  4, **  $ operation.
     116      +*  opt_parm = .f. 5, 12, **  $ parameter.
     117
     118      $   macros for unpacked parse table format.
vax  194 .+s32.
vax  195      +*  pt_op   = .f.  3,  4, **
vax  196      +*  pt_parm = .f. 17, 16, **
vax  197 ..s32
     119 .+s37.
     120      +*  pt_op   = .f.  3,  4, **
     121      +*  pt_parm = .f. 17, 16, **
     122 ..s37
utsa 229 .+s47.
utsa 230      +*  pt_op   = .f.  3,  4, **
utsa 231      +*  pt_parm = .f. 17, 16, **
utsa 232 ..s47
     123 .+s66.
     124      +*  pt_op   = .f. 1,  4, **
     125      +*  pt_parm = .f. 5, 17, **
     126 ..s66
     127 .+s10.
     128      +*  pt_op   = .f.  1, 18, **
     129      +*  pt_parm = .f. 19, 18, **
     130 ..s10
     131
     132
     133      size  i(ps);  $ loop index.
     134
     135      $   now unpack the parse table.
     136      do  i = ptmax/2 to 1 by -1;  $ unpack each pair.
     137          pt_op pt(i*2) = opt_op (.f. 1, 16, pt(i));
     138          pt_parm pt(i*2) = opt_parm (.f. 1, 16, pt(i));
     139          pt_op pt(i*2-1) = opt_op (.f. 17, 16, pt(i));
     140          pt_parm pt(i*2-1) = opt_parm (.f. 17, 16, pt(i));
     141          end do;
     142
     143      call purge;  $ initialize tables.
     144
     145      macdrop(opt_op)   macdrop(opt_parm)
     146      end subr ptdata;
       1 .=member  parse
       2      subr parse;  $ parse source text
       3      access pt;
       4      size  parseparm(ps);   $ parse item operand
       5      size  parsenow(ps);  $ position in parse table
       6      size  parseok(1);   $ parse 'ok' flag.
       7      size  pi(ps);
       8
       9      $   opcodes of the parse machine.
      10
      11      +*  po_act = 01 **  $ perform action.
      12      +*  po_bak = 02 **  $ restore parse.
      13      +*  po_err = 03 **  $ report error if failure.
      14      +*  po_jif = 04 **  $ jump if failure.
      15      +*  po_jmp = 05 **  $ jump.
      16      +*  po_lex = 06 **  $ test for token of given lexical type.
      17      +*  po_lit = 07 **  $ test for literal.
      18      +*  po_set = 08 **  $ set parse register.
      19      +*  po_sev = 09 **  $ seek zero or more instances of subpart.
      20      +*  po_sub = 10 **  $ seek subpart.
      21      +*  po_op1 = 11 **  $ user operation 1.
      22      +*  po_op2 = 12 **  $ user operation 2.
      23      +*  po_op3 = 13 **  $ user operation 3.
      24      +*  po_op4 = 14 **  $ user operation 4.
      25      +*  po_op5 = 15 **  $ user operation 5.
      26
      27      $   lexical type encoding used for po_lex operation parm field.
      28
      29      +*  lexc_name     = 01 **  $ name.
      30      +*  lexc_contok   = 02 **  $ constant.
      31      +*  lexc_cfi      = 03 **  $ control format.
      32      +*  lexc_dfi      = 04 **  $ data format code.
      33      +*  lexc_filekwd  = 05 **  $ attribute name in file statement.
      34      +*  lexc_statwd   = 06 **  $ valid filestat option.
      35      +*  lexc_dbugtok  = 07 **  $
      36      +*  lexc_ertok    = 08 **
      37      +*  lexc_exprtok1 = 09 **  $
      38      +*  lexc_exprtok2 = 10 **  $
      39      +*  lexc_termtok1 = 11 **  $
      40      +*  lexc_termtok2 = 12 **  $
      41      +*  lexc_cargstk  = 13 **
      42      +*  lexc_binop    = 14 **
      43      +*  lexc_unop     = 15 **
      44
      45      +*  lexc_max    = 15 **  $ largest lexc code.
      46
      47
      48      $   array pca (p-arse c_ontrol a-rray) contains information to
      49      $   control the parse, in particular to effect recursion within
      50      $   the parse.
      51
      52      +*  pcamax = 70 **  $ dims of -pca-
      53
      54      size  pcaptr(ps);  data pcaptr = 0;
      55      size  pca(ws); dims pca(pcamax);  $ parse recursion stack
      56
      57 .+s66.
      58      +*  pcaret(i) = .f. 1, 10,pca(i) **  $ return field in pca
      59      +*  pcaparm(i) = .f. 11, 10,pca(i) **
      60      +*  pcatot(i) = .f. 21, 10,pca(i) **
      61 ..s66
      62 .+s10.
      63      +*  pcaret(i) = .f. 1, 10,pca(i) **  $ return field in pca
      64      +*  pcaparm(i) = .f. 11, 10,pca(i) **
      65      +*  pcatot(i) = .f. 21, 10,pca(i) **
      66 ..s10
vax  198 .+s32.
vax  199      +*  pcatot(i) = .f. 1, 16, pca(i) **
vax  200      +*  pcaparm(i) = .f. 17, 16, pca(i) **
vax  201
vax  202      size  pcaret(ps);  dims pcaret(pcamax);
vax  203 ..s32
      67 .+s37.
      68      +*  pcatot(i) = .f. 1, 16, pca(i) **
      69      +*  pcaparm(i) = .f. 17, 16, pca(i) **
      70
      71      size  pcaret(ps);  dims pcaret(pcamax);
      72 ..s37
utsa 233 .+s47.
utsa 234      +*  pcatot(i) = .f. 1, 16, pca(i) **
utsa 235      +*  pcaparm(i) = .f. 17, 16, pca(i) **
utsa 236
utsa 237      size  pcaret(ps);  dims pcaret(pcamax);
utsa 238 ..s47
      73
      74      $   the operator stack opstack is used for precedence parse of
      75      $   expressions.  each entry consists of level and type.  for
      76      $   efficiency opstack is realized as two arrays rather than
      77      $   fields of a entries in a single array.
      78
      79      +*  opstackmax = 30 **   $ dimension of opstack - maximum allowed
      80      size  oplev(ps);  dims oplev(opstackmax);  $ operator level
      81      size  optyp(ps);  dims optyp(opstackmax);  $ operator type
      82
      83      size  t(ps);    $ temporary.
      84      size  lastlt(ps);  $ lexical type of prior token.
      85      size  savetok(ps);  $ saved token.
      86      size  oper(ps);    $ operation code.
      87
      88      $   begin with first word in parse table
      89      parsenow = 1;  keeptok = no;  go to parseon;
      90
      91 /parsenext/  $ advance to next parse op.
      92      parsenow = parsenow + 1;
      93
      94 /parseon/  $ process parse operation.
      95
      96      parseparm = pt_parm pt(parsenow);
      97
      98 .+pt.
      99      if  pt_op pt(parsenow) = 0 then
     100          textl(' op zero err') tintl('parsenow',parsenow) endl
     101          call genexit;  $ exit
     102          end if;
     103
     104      if  parsetrace  then
     105          tintl('parseok',parseok);
     106          tintl('parsenow ', parsenow)
     107          tintl('parseop', pt_op pt(parsenow))
     108          textl(' ')  textl((.s. (pt_op pt(parsenow)-1)*3+1, 3,
     109              'actbakerrjifjmplexlitsetsevsubop1op2op3op4op5'))
     110          tintl('  param', parseparm)
     111          endl
     112          end if;
     113
     114 ..pt
     115      go to po(pt_op pt(parsenow)) in 1 to po_op5;
     116
     117
     118 /po(po_lit)/      $  match literal given by parameter value
     119
     120      if  (keeptok=no)  call nextok;   $ get next token.
     121      if  toklc = parseparm then  $ success.
     122          parseok = yes;   keeptok = no;  $ set flags.
     123          parsenow = parsenow + 2;  $ set next operation.
     124          go to parseon;  $ continue parse.
     125      else    $   failure.
     126          parseok = no;  $ set failure status.
     127          go to parsenext;  $ go to failure point.
     128          end if;
     129
     130 /po(po_lex)/        $  find token of given lexical type
     131
     132      if  (keeptok=no)  call nextok;   $ get next token.
     133
     134      go to lexc(parseparm) in 1 to lexc_max;
     135
     136 /lexc(lexc_name)/  $ seek name.
     137
     138      if  (toklt = nametok) go to found;
     139      go to notfound;
     140
     141 /lexc(lexc_contok)/  $ seek constant.
     142
     143      if(toklt >= constok) go to found;
     144      go to notfound;
     145
     146 /lexc(lexc_cfi)/    /lexc(lexc_dfi)/   /lexc(lexc_filekwd)/
     147 /lexc(lexc_dbugtok)/   /lexc(lexc_statwd)/    /lexc(lexc_ertok)/
     148      $   the above lexical types have rather long routines to see if
     149      $   they are 'found' or not and they rarely occur.  so we will cal
     150      $   a routine to check for them.
     151      call pfind(t, parseparm);  $ call routine.
     152      if  t = 0 then  $ not found.
     153          go to notfound;
     154      elseif  t = 1 then  $ this is special find.
     155          go to found1;  $ dont hash in.
     156      else  $ found token.
     157          go to found;  $ found token.
     158          end if;
     159
     160 /lexc(lexc_exprtok1)/  $ seek one token expression.
     161
     162      if  (toklt^=nametok & toklt subpart.
     176          end if;
     177
     178      $   see if binary op which continues expressin.
     179      if  littabl(3,toklc)  then  $ if binary op, expression continu
     180          parsenow = parsenow + 2;
     181          go to po(po_op4);   $ next is xbeg.
     182          end if;
     183
     184      $   name or constant is one token expression.
     185      $   complete expr search successfully.
     186      $   do a bak now.
     187      pcaptr = pcaptr - 1;  $ pop -pca-.
     188 .+pt if  (pcaptr<0) call ermey(2);   $ fatal error.
     189      parsenow = pcaret(pcaptr+1) + 2;  $ set return point.
     190      go to parseon;   $ continue parse.
     191
     192 /lexc(lexc_termtok1)/  $ here to start term.
     193
     194 /*   assumed order of parse ops is as follows.
     195    0 lex  termtok1
     196    1 bak
     197    2 lex  termtok2
     198    3 bak
     199    4 jmp  termlp  (after seeing name, left parenthesis).
     200    5 jmp  fexp    if .f. extractor.
     201    6 jmp  eexp    if .e. extractor.
     202    7 jmp  sexp    if .s. extractor.
     203    8 jmp  checp   if .ch. extractor.
     204    9 jmp  pexp    if left parenthesis.
     205   10 jmp  termfs  if filestat.
     206
     207      the literal code is relative offset in parse table.
     208
     209 */
     210
     211      lastlt = toklt;  $ save lexical type.
     212
     213      if  (toklt>=constok)  go to found;  $ constant is term.
     214
     215      if  toklc  then  $ if literal, see if can branch forward.
     216          t = littabl(7, toklc);
     217          if  t  then
     218              parseok = yes;  keeptok = no;
     219              parsenow = pt_parm pt(parsenow + t);
     220              go to parseon;
     221              end if;
     222          end if;
     223
     224      $   if name, accept.
     225      if  (toklt=nametok)  go to found;
     226
     227      parseok = no;
     228      $   here we do a -bak-.
     229      pcaptr = pcaptr - 1;  $ pop -pca-.
     230 .+pt if  (pcaptr < 0) call ermey(2);   $ underflow.
     231      parsenow = pcaret(pcaptr+1) + 1;  $ get return point.
     232      go to parseon;  $ continue parse.
     233
     234 /lexc(lexc_termtok2)/
     235
     236      $   here after term starts with name or constant.
     237      $   if term began with constant, it is term.
     238      $   here after term starts with name.  if current token is
     239      $   left parenthesis, return to grammar to parse.  otherwise
     240      $   name is term.
     241
     242      if  toklc = lc_lparen & lastlt = nametok then
     243          parseok = yes;  keeptok = no;
     244          parsenow = pt_parm pt(parsenow+2);  $ jmp to termlp label
     245      else  $ accept
     246          parseok = yes;
     247          pcaptr = pcaptr - 1;  $ pop -pca-.
     248 .+pt     if  (pcaptr < 0) call ermey(2);   $ underflow.
     249          parsenow = pcaret(pcaptr+1) + 2;  $ get next operation.
     250          end if;
     251
     252      go to parseon;  $ continue parse.
     253
     254 /lexc(lexc_cargstk)/  $ want constant on top of -arglist-.
     255      parseok = hascon ha(arglist(argptr-1));
     256      parsenow = parsenow + parseok + 1;  $ set next parse op.
     257      go to parseon;  $ continue.
     258
     259 /lexc(lexc_unop)/   $ want valid unary operator.
     260      if  (toklc = 0) go to opret;  $ if not literal.
     261      t = littabl(4, toklc);  $ get unary operator level.
     262      if  t = 0 then  $ not operator.
     263 /opret/  $ failure return point.
     264          pcaptr = pcaptr-1;  $ failure is -b.
     265 .+pt     if  (pcaptr<0) call ermey(2);  $ error - underflow.
     266          parsenow = pcaret(pcaptr+1) + 1;  $ go to failure point.
     267          parseok = (parseparm = lexc_binop);   $ binop is bak from sev.
     268          go to parseon;  $ continue parse.
     269          end if;
     270
     271      oper = littabl(6, toklc);  $ get operator number.
     272      keeptok = no;  $ accept token.
     273      go to setoper;  $ go stack operator.
     274
     275 /lexc(lexc_binop)/   $ want binary operator.
     276      $   now see if this was either not a binary operator or
     277      $   the operator on the stack has a higher precedence.  if so,
     278      $   say 'not found'.
     279      if  (toklc = 0) go to opret;  $ no literal code.
     280      t = littabl(3, toklc);  $ get binary operator level.
     281      if  (oplev(opstackp) >= t) go to opret;  $ fail if so.
     282      oper = littabl(5, toklc);  $ get operator code.
     283      keeptok = no;   $ accept token.
     284
     285      $   now check if this is a two-token operator.
     286      if  toklc = lc_orsym then   $ !! is .cc.
     287          call nextok;  $ get next token.
     288          if  toklc = lc_orsym then  $ it is.
     289              oper = op_ccat;  $ set new operation code.
     290              keeptok = no;  $ accept operator.
     291              end if;
     292
     293      elseif  t = 4  then  $ this may be <=, >=, ^=.
     294          savetok = toklc;  $ save last token.
     295          call nextok;  $ get next token.
     296          keeptok = (toklc ^= lc_eqsym);  $ accept equal sign only.
     297          $   now determine which operator this is.
     298          if  savetok = lc_ltsym then
     299              if  (keeptok = no) oper = op_le;  $ this was <=.
     300          elseif  savetok = lc_gtsym then
     301              if  (keeptok = no) oper = op_ge;  $ this was >=.
     302          elseif  savetok = lc_notsym then
     303              if  (keeptok) call ermes(35);  $ ^ with no =
     304          else  $ this is not a multiple operator.
     305              keeptok = yes;  $ must keep token.
     306              end if;
     307          end if;
     308
     309 /setoper/  $ stack operator.
     310      countup(opstackp, opstackmax, 'opstack');
     311      optyp(opstackp) = oper;  $ set operation type.
     312      oplev(opstackp) = t;  $ set level.
     313      parseok = yes;  $ show success.
     314      parsenow = parsenow + 2;  go to parseon;  $ continue.
     315
     316
     317 /found/  $ search successful, hash in token.
     318      if  toklt = nametok  then  $ if name.
     319          insnchars = toklen;
     320 .+movw_env.
     321          call 7nmovw$li(insnarg, tokara, tokwords);  $ move words.
     322 .-movw_env.
     323          do  t = 1 to tokwords;
     324              insnarg(t) = tokara(t);
     325              end do;
     326 ..movw_env
     327
     328          call insname(t);
     329          if  assertfg  then      $ in assertion - push ptr on assert st
     330              countup(assertstp, assertdim, 'assertst');
     331              assertst(assertstp) = t;
     332              end if;
     333
     334      else  $ if constant.
     335          cclt = toklt;  $ set lexical type
     336          $   unpack tokara into array of chars. cca used by cnvcon.
     337 .+unpk_env.
     338          call 7nunpk$li(cca, 1, tokara, 1, toklen);  $ unpack token.
     339 .-unpk_env.
     340          do  t = 1 to toklen;
     341              cca(t) = .f. tokarasz+1-cs - cs*mod(t-1, tokarasz/cs), cs,
dsr   16              tokara((t-1)/(tokarasz/cs)+1);  $ copy character.
     343              end do;
     344 ..unpk_env
     345
     346          ccaptr = toklen;
     347          call cnvcon;  $ convert constant.
     348          call inscon(t); $ insert constant.
     349          end if;
     350
     351      $   place hash code on top of arg stack
     352      push(t);  $ insert on stack.
     353      if  argptr > argmax - 20 then  $ overflow of stack.
     354          call ermes(65);  call genexit;
     355          end if;
     356
     357 /found1/      $ arrive at this label if do not want token hashed
     358      parseok = yes;  keeptok = no;
     359      parsenow = parsenow + 2; go to parseon;
     360
     361 /notfound/
     362      parseok = no;
     363      go to parsenext;
     364
     365 /po(po_sev)/  $ seek several instances of subpart.
     366
     367      $   -pcaret- records where request originated
     368      $   set parameters, and go seek indicated object
     369      countup(pcaptr,pcamax,'pca');
     370      pcatot(pcaptr) = 0;
     371      pcaparm(pcaptr) = parseparm;
     372      pcaret(pcaptr) = parsenow;
     373      parsenow = parseparm;
     374      go to parseon;
     375
     376 /po(po_sub)/ $ find indicated subpart.
     377
     378      countup(pcaptr,pcamax,'pca');
     379      pcaparm(pcaptr) = 0;
     380      pcaret(pcaptr) = parsenow;
     381      parsenow = parseparm;
     382      go to parseon;
     383
     384 / po(po_err) /  $ report error if in failure state.
     385
     386      if  (parseok)  go to parsenext;
     387
     388      ermsgno = parseparm;
     389      pcaptr = 0;  $ since at top level, clear stack
     390      parsenow = parseerrloc;
     391      go to parseon;
     392
     393 /po(po_jif)/  $ jump if failure state.
     394
     395      if  (parseok)  go to parsenext;
     396
     397 /po(po_jmp)/      $  branch
     398
     399      parsenow = parseparm;  go to parseon;
     400
     401 /po(po_bak)/  $ restore parse status, return from search.
     402
     403      $   restore parser status (effectively recursion control )
     404      $   recover from completion of -find subpart- or
     405      $   -find repeated instances- operation
     406
     407      if  pcaparm(pcaptr) = 0  then  $ if subpart.
     408          pcaptr = pcaptr-1;
     409 .+pt     if  (pcaptr<0) call ermey(2);
     410          parsenow = pcaret(pcaptr+1) + 1 + parseok;
     411      else  $ restore after search for repeated instances
     412          if  parseok  then $ continue search
     413              pcatot(pcaptr) = pcatot(pcaptr) + 1;
     414              parsenow = pcaparm(pcaptr);
     415          else  $ part not found, return instance count found
     416              pcaptr = pcaptr-1;
     417 .+pt         if  (pcaptr<0) call ermey(2);
     418              parsenow = pcaret(pcaptr+1) + 1;
     419              arglist(argptr) = pcatot(pcaptr+1);
     420              parseok = yes;
     421              end if;
     422          end if;
     423
     424      go to parseon;   $ continue with parse.
     425
     426 /po(po_set)/  $ set parse register.
     427
     428      $   setting parsereg(1) is doing an 'ok' so special-case that.
     429      if  .f. 1, 3, parseparm = 0 then
     430          parseok = yes;  $ this is 'ok'.
     431      else    $   normal register sets.
     432          parsereg(1 + (.f. 1, 3, parseparm)) = .f. 4, 9, parseparm;
     433          end if;
     434
     435      go to parsenext;
     436
     437 /po(po_op1)/  $ op1 saves parseparm in pi.
     438
     439      pi = parseparm;
     440      go to parsenext;
     441
     442 /po(po_act)/  $ action sequence.
     443
     444      go to pa(parseparm) in 1 to parseactmax;
     445
     446      +*  pac = go to parsenext **
     447
     448      +*  pr(i) = parsereg(i) **
     449 $ member synact
     450 / pa(   1) /  call gensub ( pi );                               pac;
     451 / pa(   2) /  call gengosl ( pi );                              pac;
     452 / pa(   3) /  call gengol ( pi );                               pac;
     453 / pa(   4) /  call genif ( pi );                                pac;
     454 / pa(   5) /  call genwhil ( pi );                              pac;
     455 / pa(   6) /  call genuntl ( pi );                              pac;
     456 / pa(   7) /  call gendo ( pi );                                pac;
     457 / pa(   8) /  call genend;                                      pac;
     458 / pa(   9) /  call gensiz;                                      pac;
     459 / pa(  10) /  call gendim;                                      pac;
     460 / pa(  11) /  call gendat ( pi );                               pac;
     461 / pa(  12) /  call genns;                                       pac;
     462 / pa(  13) /  call genacc;                                      pac;
     463 / pa(  14) /  call genreal;                                     pac;
     464 / pa(  15) /  call gencall ( pi );                              pac;
     465 / pa(  16) /  call gengoby;                                     pac;
     466 / pa(  17) /  call genret;                                      pac;
     467 / pa(  18) /  go to checkcexp;
     468 / pa(  19) /  call gencont ( pi );                              pac;
     469 / pa(  20) /  call genquit;                                     pac;
     470 / pa(  21) /  call genasin ( pr ( 7 ) , pr ( 5 ) );             pac;
     471 / pa(  22) /  call geniost ( pi );                              pac;
     472 / pa(  23) /  call geniotr;                                     pac;
     473 / pa(  24) /  call genioit ( pi );                              pac;
     474 / pa(  25) /  call gencfi ( pi );                               pac;
     475 / pa(  26) /  call gendfi ( pi );                               pac;
     476 / pa(  27) /  call genfile;                                     pac;
     477 / pa(  28) /  call gentrace ( pr ( 4 ) , 8 );                   pac;
     478 / pa(  29) /  call gentrace ( pr ( 4 ) , 7 );                   pac;
     479 / pa(  30) /  call gentrace ( pr ( 4 ) , pr ( 3 ) + 1 );        pac;
     480 / pa(  31) /  call gentrace ( pr ( 4 ) , pr ( 3 ) );            pac;
     481 / pa(  32) /  call gensert ( pi );                              pac;
     482 / pa(  33) /  call gendebug ( 0 , 0 );                          pac;
     483 / pa(  34) /  call gendebug ( 0 , 1 );                          pac;
     484 / pa(  35) /  call gendebug ( 1 , 1 );                          pac;
     485 / pa(  36) /  call gendebug ( dparm , dval );                   pac;
     486 / pa(  37) /  keeptok = 1;                                      pac;
     487 / pa(  38) /  call genextr ( pi );                              pac;
     488 / pa(  39) /  call ermet;                                       pac;
     489 $ end member synact
     490
     491 /po(po_op2)/  $ get bronlit argument, searches literal.
     492
     493      $   this action implements the branch on literal feature in the
     494      $   grammar.  the next token in input is examined.  if it has been
     495      $   assigned a number in the given class, the grammar table
     496      $   pointer, parsenow, is advanced by that number, else the token
     497      $   is simply returned and parnsing proceeds with the next item.
     498
     499
     500      parseok = no;  $ assume not found.
     501      if  (keeptok=no)  call nextok;   $ get next token.
     502      if  (toklc = 0) go to parsenext;  $ normal token.
     503      t = littabl(parseparm, toklc);  $ if literal.
     504      if  t then  $ will take branch.
     505          parseok = yes;  keeptok = no;  $ show success.
     506          parsenow = pt_parm pt(1 + (parsenow+t));  $ set next op.
     507          go to parseon;  $ continue parse.
     508          end if;
     509
     510      go to parsenext;  $ else continue with next.
     511
     512 /po(po_op3)/
     513
     514      $   this action pops opstack and calls arith or marith with
     515      $   appropriate parameter
     516
     517
     518 .+pt.
     519      if  opstackp = 1 then
     520          call ermey(6);
     521          end if;
     522 ..pt
     523
     524      opstackp = opstackp - 1;
     525      t = optyp(opstackp+1);
     526      if parseparm = 1 then call arith(t);
     527          else call marith(t);  end if;
     528      go to parsenext;
     529
     530 /po(po_op4)/    $ stack expression.
     531
     532      countup(opstackp, opstackmax, 'opstack');
     533      oplev(opstackp) = 0; optyp(opstackp) = 0;
     534      go to parsenext;
     535
     536
     537 /po(po_op5)/    $ unstack expression.
     538
     539 .+pt.
     540      if  oplev(opstackp) then
     541          call ermey(4);
     542          end if;
     543
     544      if  opstackp = 0 then
     545          call ermey(5);
     546          end if;
     547 ..pt
     548
     549      opstackp = opstackp - 1;
     550      go to parsenext;
     551
     552
     553 /checkcexp/  $ here to check for expression in constants.
     554
     555      if  parsereg(6) then  $ must be safe constant.
     556          if  (hascon ha(arglist(argptr-1))) go to parsenext;  $ ok.
     557      else  $ want any constant.
     558          if  var ha(arglist(argptr-1)) then  $ is variable or constant.
     559              if  (const voa(ep ha(arglist(argptr-1)))) go to parsenext;
     560              end if;
     561          end if;
     562
     563      call ermes(42);  $ give error message
     564      arglist(argptr-1) = ha_1;  $ reset value
     565
     566      go to parsenext;
     567
     568      end subr parse;
       1 .=member  pfind
       2      subr pfind(ret, lexc);   $ do find actions for some classes.
       3      size  ret(ps);   $ 0=notfound, 1=found1, 2=found.
       4      size  lexc(ps);    $ lexical class.
       5      size  keycode(ps);  $ function which returns code from string.
       6      size  i(ps);    $ do loop variable.
       7
       8      go to lexc(lexc) in lexc_cfi to lexc_ertok;
       9
      10 /lexc(lexc_cfi)/  $ seek control format code.
      11
      12      if  toklt = strtok  then
      13          iokey = 5;   $ global passed to gencfi
      14          go to found;   $ hash in sds
      15          end if;
      16
      17      if  (toklt ^= nametok)  go to notfound;
      18      if(toklen > keylenmax) go to notfound;
      19      call psdstok;
      20      iokey = keycode(sdsnamstr,  $ control codes follow.
      21          '04=x 02=skip 03=page 01=column ');
      22      if  (iokey)  go to found1;
      23      go to notfound;
      24
      25 /lexc(lexc_dfi) /  $ seek data format item, process initial -n-.
      26
      27      if  (toklt ^= nametok)  go to notfound;
      28      if  (toklen > 3)  go to notfound;
      29      $   convert token to sds form, put in iosds.
      30      call psdstok;
      31      ionameflag = no;
      32      if  .ch. 1, sdsnamstr = 1rn  then  $ if -n- type format
      33          ionameflag = yes;
      34          do  i = 2 to toklen;
      35              .ch. i-1, sdsnamstr = .ch. i, sdsnamstr;  end do;
      36          slen sdsnamstr = toklen-1;
      37          toklen = toklen - 1;
      38          end if;
      39
      40      iokey = 0;
      41      if  (toklen=0) go to notfound;
      42      iolistmode = no;
      43      if  .ch. slen sdsnamstr, sdsnamstr = 1rl  then  $ if list mode
      44          iolistmode = yes;
      45          slen sdsnamstr = slen sdsnamstr - 1;
      46          toklen = toklen - 1;
      47          if  (toklen = 0)  go to notfound;
      48          end if;
      49
      50      iokey = keycode(sdsnamstr, $ string gives format codes
      51          '01=a 02=b 03=e 04=f 05=i 06=r ');
      52      if  (iokey) go to found1;  go to notfound;
      53
      54 /lexc(lexc_filekwd)/
      55
      56      $     seek valid attribute for 'file' statement.
      57      $     convert token into sds format in sdsnamstr.
      58      if  (toklt^=nametok) go to notfound;
      59      if  (toklen>keylenmax)  go to notfound; $ if token too long.
      60      call psdstok;
      61      iokey = keycode(sdsnamstr, $ next line gives attribute codes
      62      '01=title 02=access 03=linesize ');
      63      if  (iokey) go to found1; go to notfound;
      64
      65 /lexc(lexc_dbugtok)/
      66
      67      $   seek parameter for 'debug' statement
      68      if  (toklt ^= nametok ! toklen > keylenmax) go to notfound;
      69      call psdstok;
      70      dparm = keycode(sdsnamstr, $ string gives parameters
      71      '02=nolimit 04=nobyte 05=byte 06=noflow 07=flow 08=nostores
      72      09=stores 10=noentry 11=entry ');
      73      dval = .f. 1, 1, dparm; dparm = .f. 2, ps, dparm; $ split
      74      if  (dparm) go to found1; go to notfound;
      75
      76 /lexc(lexc_statwd)/
      77
      78      $   seek 'filestat' attribute
      79      if  (toklt^=nametok ! toklen>keylenmax) go to notfound;
      80      call psdstok;
      81      iokey = keycode(sdsnamstr, $ string gives filestat codes.
      82 '01=column 02=end 03=error 03=err 04=ignore 05=access 06=linesize '
      83      !! '07=stream ');
      84      if  (iokey) go to found1; go to notfound;
      85
      86 /lexc(lexc_ertok)/   $ skip to end of statement on error.
      87      $   this lexical class is used to recover from an error.
      88      $   it will skip forward to next semicolon unless the error
      89      $   occured in an expression in an -if- in which case it
      90      $   will scan for either a 'then' or a semicolon.
      91      if  cstype csa(csaptr) = cstype_if then  $ last opener was -if-.
      92          $   if this was simple -if-, end simple statement.
      93          if  csiftype csa(csaptr) = csiftype_sif then
      94              call genif(4);  $ end the simple statement.
      95          elseif  csiftype csa(csaptr) = 0 then  $ in expression.
      96              if  toklc = lc_then  then  $ found 'then'.
      97                  push(ha_1);  call genif(2);  $ dummy expression.
      98                  go to notfound;  $ terminates search for token.
      99              elseif  toklc = lc_semicolon then  $ this was simple -if-.
     100                  push(ha_1); call genif(3); call genif(4);  $ null sta
     101                  go to notfound;  $ terminates search for token.
     102                  end if;
     103              end if;
     104          end if;
     105
     106      $   if normal case, only semicolon ends.
     107      if  (toklc = lc_semicolon) go to notfound;  $ terminates search.
     108      go to found1;   $ else continue search.
     109
     110
     111 /found/  ret = 2;  return;
     112 /found1/ ret = 1; return;
     113 /notfound/   ret = 0; return;
     114
     115      end subr pfind;
       1 .=member  psdstok
       2      subr psdstok;  $ convert token into sds form
       3      $   convert token into sds form, put result in -sdsnamstr-.
       4      $   (this auxiliary routine called from -pfind-.)
       5      size  i(ps);  $ do loop index
       6      slen sdsnamstr = toklen;
       7      do  i = 1 to tokwords;
       8          .f. nameorg - i*ws, ws, sdsnamstr = tokara(i);
       9          end do;
      10
      11      end subr psdstok;
       1 .=member  keycode
       2      fnct keycode(key, codes); $ seek -key- in -codes-, get value.
       3      $   -key- and -codes- are strings.  entries of -codes- have the
       4      $   form 'nn=str' where nn is integer and str is code.  if
       5      $   -key- corresponds to one of the entries, return numeric
       6      $   value of assigned code nn; otherwise return 0.
       7      size  key(sds(keylenmax));  $ key for which code desired
       8      size  codes(sds(120));  $ string of codes
       9      size  s(namsz);  $ delimited form of key
      10      size  keycode(ps);  $ function vlaue.
      11      size  i(ps);  $ do loop index for conversion.
      12
      13      keycode = 0;  $ assume key not present.
      14      if  (slen key > keylenmax) return;  $ too large, cannot be present
      15      sorg s = nameorg;  $ set string origin field.
      16      slen s = slen key+2;
      17      .ch. 1, s = 1r=;  .ch. slen s, s = 1r ; $ enter delimiters.
      18      do  i = 1 to slen key;
      19          .ch. i+1, s = .ch. i, key;  end do;
      20      i = s .in. codes;
      21      if  (i=0) return;
      22      keycode = digofchar((.ch.i-2,codes))*10
      23              + digofchar((.ch.i-1,codes));
      24
      25      end fnct keycode;
       1 .=member  gtoflo
       2      subr gtoflo(ipoin, lim, iword);  $ increment counter
       3      $   increment -ipoin-, fatal error if -ipoin- >= -lim-.
       4      size  ipoin(ps);
       5      size  lim(ps);
       6      size  iword(ws+1);  $ name of array which overflowed
       7
       8      terml(yes);  $ write this to terminal file
mgfc  14 .+s10    error_s10;  $ give s10 error character.
       9      textl(error_notice) textl('array ') textl(iword)
      10      textl(' overflowed: ')
      11      tintl('pointer ',ipoin)  tintl(' limit',lim) endl
      12      terml(no);  $ done with terminal file output
      13      call genexit;  $ terminate
      14      end subr gtoflo;
       1 .=member  nextok
       2      subr nextok;  $ get next token
       3      $   obtain next token from input stream, unless -keeptok- is on,
       4      $   in which case return prior token.  if -echoline- on, then
       5      $   do nothing but list the last read if it has not yet been
       6      $   listed (this action requested as part of error report).
       7      $   check for 'special' period-delimited tokens,
       8      $   such as '.voadump.' which requests symbol table dump, etc.
       9      $   set -toklc- to literal code, -toklt- to lexical type,
      10      $   -toklen- to length of token in characters,
      11      $   -tokwords- to number of words in
      12      $   token, and insert token in array -tokara-.
      13      size  i(ps);            $ do loop index
      14      size  tokhdr(ws);  $ token descriptor word
      15      size  toktrace(1); data toktrace=0;  $ on to trace tokens read
      16      size  titletext(.sds. (cpw*wpc));  $ text of title directive.
      17      size  new(voasz);       $ voa item built by list code change.
      18
      19      +*  tokread1(wd) = $ get one word from token buffer/file
      20          if  tokrbufp >= tokrbuflim  then
      21          call rdrwsio(tokenfile, iorc, tokrbuf, 1, tokrbuflim);
      22              tokrbufp=0;
      23              end if;
      24          tokrbufp = tokrbufp + 1;  wd = tokrbuf(tokrbufp);
      25          **
      26
      27      +*  tokread(ara, wds) = $ read wds words into ara(1) to ara(wds).
      28          size  zzzi(ps);  $ do loop index.
      29          if  (wds+tokrbufp) >= tokrbuflim  then $ if would empty buf,
      30              do  zzzi = 1 to wds;
      31                  tokread1(ara(zzzi)); end do;
      32          else
      33 .+movea_env.
      34              call 7nmova$li(ara, 1, tokrbuf, tokrbufp+1, wds);  $ copy.
      35 .-movea_env.
      36              do  zzzi = 1 to wds;
      37                  ara(zzzi) = tokrbuf(tokrbufp + zzzi);  end do;
      38 ..movea_env
      39              tokrbufp = tokrbufp + wds;
      40              end if;
      41          **
      42
      43      keeptok = yes;
      44 /rdtok/
      45      tokread1(tokhdr);  $ read token descriptor
      46      toklt =tokrtyp tokhdr;  $ get lexical type/code
      47      toklen = tokrlen tokhdr;  $ no ov chars
      48      toklc = tokrlc tokhdr;   $ literal code
      49      tokwords = (toklen-1)/cpw + 1;  $ no of words
      50      if  (toklen = 0)  tokwords = 0;
      51      if  toktrace then
      52          tintl(' token, lt',toklt) tintl(' len',toklen)
      53          tintl(' lc', toklc) endl
      54          end if;
      55      go to t(toklt) in 1 to tokreof;
      56  /t(listcontroltok)/  $  .=list directive or change.
      57      if  toklen = 2  then  $ change in list input mode.
      58          $   save new value in listswnew until next line read.
      59          listswnew = toklc;
      60      elseif toklen = 1  then  $ change in code list mode.
      61      $   must pass on changed code listing option to asm phase.
      62      $   build voa op with opcode = op_list,
      63      $   inp1 = 1 to mark as listing change and inp2 = new option.
      64 $        if  voptr ^= voafnct  then  $ avoid making first entry in voa.
      65 $            new = 0;  opb new = yes;  opcode new = op_list;
      66 $            inp1 new = 1;  inp2 new = toklc;
      67 $            voa(voptr) = new;  voaup;
      68 $            end if;
      69          listingcode = toklc;  $ pass in voa header frame.
      70      elseif  toklen = 3 then  $ change titling mode
      71          listauto = toklc;
      72          end if;
      73      go to rdtok;
      74 /t(listejecttok)/    $ .=eject
      75      if  listsw  then  $ if listing on, do eject action.
      76          call lstlin;  $ if listing input.
      77          ejectlp(toklen);
      78          end if;
      79      go to rdtok;
      80 /t(listtitletok)/    $ .=title
      81      if  (listsw)  call lstlin;  $ if listing input.
      82      if  toklen  then  $ if title not null, read it.
      83          tokread(tokara, tokwords);
      84          sorg titletext = 1 + .sds. toklen;
      85          do  i = 1 to tokwords;
      86              .f. sorg titletext - i*ws, ws, titletext = tokara(i);
      87              end do;
      88          end if;
      89      sorg titletext = 1 + .sds. toklen;
      90      slen titletext = toklen;
      91      if  (listauto) subtitling = no;  $ use main title in auto mode
      92      if  (listsw) call stitlr(subtitling, titletext);
      93      if  subtitling & listsw  then
      94          ejectl;   $ eject if listing and is subtitle.
      95          end if;
      96      subtitling = yes;
      97      go to rdtok;
      98
      99 /t(7)/   /t(9)/   /t(10)/   /t(11)/   /t(13)/
     100 /t(15)/  /t(16)/  /t(17)/  /t(18)/  /t(19)/ /t(20)/
     101 /t(21)/  /t(22)/  /t(23)/  /t(24)/  /t(25)/ /t(26)/
     102      call ermey(9);
     103
     104 /t(tokrcard)/           $  card image being transmitted
     105      if  (listsw)  call lstlin;  $ if listing input.
     106      listsw = listswnew;  $ set if new value, or copy if old.
     107      ncards = ncards + toklc;  proclineno = proclineno + toklc;
     108      cardlisted = no;  $ new card read, not yet listed
     109      listwdsp = tokwords;  $ save length
     110      if  tokwords  then  $ if need to read card image.
     111          tokread(listwds, tokwords);  $ read card image.
     112          end if;
     113      go to rdtok;  $ get next token
     114
     115 /t(tokreof)/  $ end-of-file token
     116      if  (listsw)  call lstlin;  $ if listing input.
     117      exitcode = 0; call genexit;   $ else exit, done
     118
     119 /t(nametok)/
     120 /t(spectok)/
     121 /t(pdotok)/
     122 /t(dectok)/
     123 /t(strtok)/
     124 /t(bittok)/
     125 /t(rztok)/
     126 /t(sstok)/
     127 /t(realtok)/
dso  108 .+s10  tokara(2) = blankword;
vax  207 .+s32    tokara(2) = blankword;
     128 .+s37    tokara(2) = blankword;
utsa 239 .+s47    tokara(2) = blankword;
     129      if  toklen <= cpstr then
     130          tokara(1) = blankword;
     131          tokrval tokara(1) = tokrval tokhdr;
     132      else
     133          tokread(tokara, tokwords);
     134          end if;
     135      if  toktrace then
     136          textl('token = ')
     137          do  i = 1 to tokwords;
     138              wordl(tokara(i))
     139              end do;
     140          endl
     141          end if;
     142      lexlist(lexlistptr+1) = tokara(1);  $ save token
     143      lexleng(lexlistptr+1) = toklen;  $ save token length.
     144      lexlistptr = (lexlistptr+1) & (lexlistmax-1);
dso  109 .+s10    lexlist(lexlistptr+1) = tokara(2); $ extra word for s10.
dso  110 .+s10    lexlistptr = (lexlistptr+1) & (lexlistmax-1);
vax  208 .+s32    lexlist(lexlistptr+1) = tokara(2);  $ save extra word for s32
vax  209 .+s32    lexlistptr = (lexlistptr+1) & (lexlistmax-1);
     145 .+s37    lexlist(lexlistptr+1) = tokara(2);  $ save extra word for s37
utsa 240 .+s47    lexlist(lexlistptr+1) = tokara(2);  $ save extra word for s47
     146 .+s37    lexlistptr = (lexlistptr+1) & (lexlistmax-1);
utsa 241 .+s47    lexlistptr = (lexlistptr+1) & (lexlistmax-1);
     147      if(toklt ^= pdotok) go to notapdo;
     148
     149      $   check for special directive to parser, or machine parameter
     150      $   which must be replaced by value.
     151
     152      if  (toklc = 0)  go to notapdo;
     153      i = littabl(9, toklc);
     154      if  (i=0)  go to notapdo;
     155      go to l(i) in 1 to 13;
     156
     157 / l(1) /    $ .voadump.
     158 / l(2) /    $ .voapart.
     159      call tabdump(1, voptr, 2-i);  $ dump tables.
     160
     161 / l(3) /   / l(4) /   $ unused.
     162      go to rdtok;
     163
     164      / l( 5) /  $  .contr. - start listing converted constant values.
     165          $  this flag examined by routine cnvcon.
     166          docontrace = yes;  go to rdtok;
     167
     168      / l( 6) /  $ .nocontr. - terminate list of converted constants.
     169          docontrace = no;  go to rdtok;
     170
     171      / l( 7) /  $ .toktr. - list tkokens as read.
     172          toktrace = yes;  go to rdtok;
     173
     174      / l( 8) /  $ .notoktr. - terminate list of tokens as read.
     175          toktrace = no;  go to rdtok;
     176
     177      / l(9)/    / l(10) /    / l(11) /    / l(12) /    / l(13) /
     178      $   convert target mahchine parameters to value.
     179      $   warning. code currently assumed that tokara(1) can hold number
     180      $   of characters (now 2) needed to specify machine paramater
     181      $   value.
     182      tokara(1) = tmtokara(i-8);
     183      toklen = 2;  toklt = dectok;  toklc = 0;
     184      $   thus substituting value for operator originally present.
     185
     186      $   is not special token, pass on
     187 /notapdo/
     188      if  savetoks < 5 then $ save token in csatok for opener
     189          savetoks = savetoks + 1;
     190          csatokptr = csatokptr + 1;
     191          csatok(csatokptr) = tokara(1);
     192          end if;
     193
     194      if  toklt = realtok then   $ this is real token.
     195          $   check if supported on this machine.
     196          if  targetmachine = m11 then  $ not supported.
     197              call ermes(69);  $ print error.
     198 /unstok/     $   here to fix unsupported constants.
     199              tokara(1) = blankword;  $ start to set to 1.
     200              .f. ws+1-cs, cs, tokara(1) = 1r1;  $ set to one.
     201              toklen = 1;  toklt = dectok;  $ set length and type.
     202              end if;
     203          end if;
     204
     205      if  toklt = sstok then  $ this is special string token.
     206          $   see if target machine supports it.
     207          if  targetmachine ^= m11 then  $ only pdp-11 supports it now.
     208              call ermes(9);   $ print error message.
     209              go to unstok;  $ convert it to integer 1.
     210              end if;
     211          end if;
     212
     213      end subr nextok;
       1 .=member  lstlin
       2      subr lstlin;  $ list input line.
       3      size  i(ps);  $ loop index.
       4
       5      if  cardlisted=no  then  $ if need to list.
       6          cardlisted = yes;
rbko  10          intl(proclineno)  skipl(3)
       8          do  i = 1 to listwdsp;  $ list each word.
       9              wordl(listwds(i));
      10              end do;
      11          endl
      12          end if;
      13
      14      end subr lstlin;
       1 .=member  cnvcon
       2      subr cnvcon;  $ convert constant.
       3      $   convert 'safe' constants to their internal (binary) form.
       4
       5      size  i(ps);
       6 $ note - size of rcv should be rlsz (or .rs.) when
       7 $ .rs. pararameter installed.
       8      size  rcv(ws);  $ real constant built here
       9      size  longint(ws);  $ for integers near word size.
      10      size  longresult(szmax-ws);  $ build long constants here
      11      $   size is less than szmax so that temporary generated for
      12      $   longresult * 10  has size no greater than szmax.
      13
      14      size  c(ps);  $ holds character, then numeric val
      15      +*  charin(c) = ccaptr = ccaptr+1; cca(ccaptr) = c; **  $ to add
      16      size  stringlen(ps);  $ length of string
      17      size  charsrem(ps);  $ no of chars left in word
      18      size  sdskel(ws);  $ skeleton for self-def strings built up heree
      19      size  sdlast(ps);       $ no of chars used in last word of str
      20      size  sdleft(ps);       $ no of remaining char posns in last wd
      21      size  sddpos(ps);       $ position when moving desc into val of sd
      22      size  cpsdd(ps);  $ no. of characters in slen,sorg fields.
      23      size  j(ps);            $ do loop index.
      24      size  bitwidth(ps);     $ no. of bits per char in bit constant.
      25      size  bytenow(ps);       $ current bit value.
      26      size  expval(ws);       $ real exponent value.
      27
      28      ccvalptr = 1;  $ assume 1 word constant
      29      ccval(1) = 0;
      30      ccsyze = 1;  $ will return 0 if can not convert.
      31      stringlen = ccaptr;
      32      ccnchars = 0;
      33      go to l(cclt) in 1 to toktypes;
      34
      35 / l(realtok) /  $ real constant.
      36          ccsyze = rlsz;
      37      if  safeconst(realtok)  then  $ if safe, convert real.
      38      call 7nvnum$io(cca, ccaptr, expval);
ldsd  24      if  cca(ccaptr+2)  then  $ if invalid.
ldsd  25          call ermes(10);
ldsd  26          ccsyze = 1;  $ take as zero.
ldsd  27          go to converted;
ldsd  28          end if;
      39      if  cca(ccaptr+3) > 1  then  $ if point present, adjust exponent.
      40          expval = expval - (cca(ccaptr+3) - 1);
      41          end if;
      42      call 7ncefr$io(rcv, cca, ccaptr, expval);
ldsd  29      if  cca(ccaptr+2)  then  $ if invalid.
ldsd  30          call ermes(10);
ldsd  31          ccsyze = 1;  $ take as zero.
ldsd  32          go to converted;
ldsd  33          end if;
      43          do  i = 1 to rlsz/mws;
      44              ccval(i) = .f. rlsz+1-i*mws, mws, rcv;
      45              end do;
      46          go to converted;
      47      else
      48          ccvalptr = (ccaptr-1)/cpw + 1;
      49          ccnchars = ccaptr;
      50          go to endofstr;
      51          end if;
      52
      53 / l(nametok) /
      54 / l(spectok) /
      55 / l(pdotok)  /
      56 /l(7)/   /l(9)/  /l(10)/  /l(11)/  /l(13)/
      57          call ermey(8);
      58
      59 /l(bittok)/
      60      bitwidth = digofchar(cca(1));
      61      ccsyze = 0;
      62      do  i = ccaptr-1 to 4 by -1;
      63          c= cca(i);  if  (c = 1r ) cont do;
      64          if  c >= 1r0 & c <= 1r9 then   $ is a digit.
      65              bytenow = digofchar(c);  $ get value.
      66          else   $ must be hex a-f.
      67              bytenow = c - 1ra + 10;  $ get value.
      68              end if;
      69
      70          if  ccsyze+bitwidth <= ws  then
      71              .f. ccsyze+1, bitwidth, ccval(1) = bytenow;
      72          else
      73              if  ccsyze <= ws  then
      74                  longresult = ccval(1);
      75                  end if;
      76              do  j = 1 to bitwidth;
      77                  .f. ccsyze+j, 1, longresult = .f. j, 1, bytenow;
      78                  end do;
      79              end if;
      80          ccsyze = ccsyze + bitwidth;
      81          end do;
      82      if  ccsyze <= ws  then
      83          ccsyze = .fb. ccval(1);
      84      else
      85          ccsyze = .fb. longresult;
      86          if  ccsyze <= ws  then
      87              ccval(1) = .f. 1, ws, longresult;
      88              end if;
      89          end if;
      90      if  (ccsyze = 0)  ccsyze = 1;
      91      if  (ccsyze > ws)  go to packlong;
      92      go to converted;
      93
      94 /packlong/
      95      ccvalptr = (ccsyze-1) / ws;
      96      do  i = 0 to ccvalptr;
      97          ccval(ccvalptr+1-i) = .f. 1+i*ws, ws, longresult;
      98          end do;
      99      ccvalptr = ccvalptr + 1;
     100      go to converted;
     101
     102 / l(dectok) /
     103      do  i = 1 to ccaptr;                $ decimal conversion
     104          ccsyze = .fb. ccval(1);
     105 .+s66.
     106        if  (ccsyze > 44) go to largeint;
     107      $   the above machine dependent command is the result of the
     108      $   chintzy integer multiply on the 6600.
     109 .-s66.
     110      $   on a better target
     111      $   machine, replace the condition with the machine independent
     112      $   (ccsyze>(ws-4)) since allow 4 bits to multiply by 10.
     113      if (ccsyze>(ws-4)) go to largeint;
     114 ..s66
     115        ccval(1) = ccval(1) * 10 + digofchar(cca(i));   $ machine depe
     116        end do;
     117      ccsyze = .fb. ccval(1);
     118      if  (ccsyze=0) ccsyze = 1;
     119      go to converted;
     120 /largeint/
     121      longint = ccval(1);
     122      do  i = i+1 to ccaptr;
     123          ccsyze = .fb. longint;
     124          if  (ccsyze > (mws-3)) go to toobig;
     125 .-s66    longint = longint * 10 + digofchar(cca(i));
     126 .+s66.   $   on s66, do via shift due to limited range
     127      $   of multiply.
     128          longint = longint*8 + longint*2 + digofchar(cca(i));
     129 ..s66
     130          end do;
     131      ccsyze = .fb. longint;
     132      ccval(1) = longresult;  ccvalptr = 1;
     133      go to converted;
     134
     135
     136 /toobig/
     137      call ermes(13);
     138      ccsyze = 1; ccval(1)=0; ccvalptr=1; go to converted;
     139
     140
     141 / l(strtok) /
     142      ccnchars = stringlen;
     143      if  safeconst(strtok)=no  then $ if should not convert,
     144          if  ccaptr=0  then  $ if null string.
     145              ccsyze=0;
     146              ccsyze = mws*((msl+mso+mws-1)/mws);
     147              go to converted;  end if;
     148          ccsyze = ((ccaptr*mcs + msl + mso + mws-1)/mws)*mws;
     149          ccvalptr = (ccaptr-1)/cpw + 1;
     150          go to endofstr;
     151          end if;
utsa 242
utsa 243 .+s37  if (ebcascoption)  call ebcasc;
     152
     153      sdskel = 0;  $ descriptor build up here
utsb   1      .f. 1, msl, sdskel = ccaptr; $ no of chars in string
     155      sdlast = ccaptr - cpw*(ccaptr/cpw); $ position of last char in wd
     156      $   cpsdd is number of characters that could be held in sorg,slen
     157      $   fields.  at present, it is assumed that (.sl.+.so.) is
     158      $   multiple of .cs. .
     159      cpsdd = (msl+mso)/mcs;
     160      if  sdlast=0 then  sdlast = cpw;end if;
     161      sdleft = cpw - sdlast; $ remaining chars in last word
     162      $   now pad with zeros if necessary
     163      if  sdleft > cpsdd then
     164          do  i =  1 to  sdleft-cpsdd; charin(0); end do;
     165      else if sdleft < cpsdd then
     166          do  i =  1 to  (sdleft + (cpw-cpsdd) ); charin(0); end do;
     167          end if ;
     168          end if;
utsb   2      .f. msl+1, mso, sdskel = (ccaptr + cpsdd) * cs  + 1  ;
     170      sddpos = cpsdd*cs + 1;  $ put descriptor val in string rep
     171      while(sddpos>1);
     172          sddpos = sddpos - cs;  $ move to next char pos
     173          charin( (.f. sddpos, cs, sdskel) );
     174          end while;
     175      ccsyze = mws*((ccaptr*mcs + mws-1)/mws);
     176          ccvalptr = (ccaptr-1)/cpw + 1;
     177      go to endofstr;
     178
     179
     180 / l(rztok) /
     181      if  safeconst(rztok)  then  $ if should convert.
utsa 244 .+s37    if  (ebcascoption)  call ebcasc;
     182          charsrem = ((ccaptr+cpw-1)/cpw) * cpw - ccaptr;
     183          ccaptr = charsrem + stringlen;
     184          if  (ccaptr = 0)  go to converted;  $ this is null string.
     185          do  i = 0 to stringlen-1;
     186              cca(ccaptr-i)=cca(stringlen-i);
     187              end do;
     188          do  i =  1 to  charsrem;
     189              cca(i) = 0;
     190              end do; $ insert leading zero
     191          end if;
     192
     193 / l(sstok) /
     194      ccnchars = stringlen;
     195      if  (ccaptr=0) go to converted;  $ if null, return 0.
     196      ccsyze = ccnchars * mcs;  $ assume r-type.
     197      if  (cclt = sstok) ccsyze = mws*((ccnchars+2)/3);  $ rad-50 on s11
     198      ccvalptr = (ccaptr -1)/cpw + 1;
     199 /endofstr/
     200 .+pack_env    call 7npack$li(ccval, 1, cca, 1, ccaptr);  $ if fast pack
     201 .-pack_env    call linepak(ccval, cca, ccaptr);
     202 /converted/
     203      if  docontrace then
     204          tintl(' type',cclt)
     205          tintl('len',ccaptr) tintl('bits',ccsyze)
     206          tintl('words',ccvalptr)  endl
     207          call dumpaq(' converted constant ', ccval, 1, ccvalptr);
     208          end if;
     209      macdrop(charin)
     210      end subr cnvcon;
utsa 245 .+s37.
utsa 246      subr ebcasc;  $ convert from ebcdic to ascii
utsa 247 $    convert character string data in cca from ebcdic to ascii.
utsa 248 $    the conversion table is that used by cdc in the 8-bit subroutine
utsa 249 $    package and is used to write ebcdic tapes at nyu. it agrees with
utsa 250 $    values used by dec for vms, except vms map takes ascii to be 7-bit
utsa 251 $    code.
utsa 252      size  i(ps);
utsc   8          size  ctlc(cs);
utsa 253      size ebcasctab(.ws.); dims ebcasctab(256);
utsa 254      data ebcasctab =
utsa 255      4b'00', 4b'01', 4b'02', 4b'03', 4b'9c', 4b'09', 4b'86', 4b'7f',
utsa 256      4b'97', 4b'8d', 4b'8e', 4b'0b', 4b'0c', 4b'0d', 4b'0e', 4b'0f',
utsa 257      4b'10', 4b'11', 4b'12', 4b'13', 4b'9d', 4b'85', 4b'08', 4b'87',
utsa 258      4b'18', 4b'19', 4b'92', 4b'8f', 4b'1c', 4b'1d', 4b'1e', 4b'1f',
utsa 259      4b'80', 4b'81', 4b'82', 4b'83', 4b'84', 4b'0a', 4b'17', 4b'1b',
utsa 260      4b'88', 4b'89', 4b'8a', 4b'8b', 4b'8c', 4b'05', 4b'06', 4b'07',
utsa 261      4b'90', 4b'91', 4b'16', 4b'93', 4b'94', 4b'95', 4b'96', 4b'04',
utsa 262      4b'98', 4b'99', 4b'9a', 4b'9b', 4b'14', 4b'15', 4b'9e', 4b'1a',
utsa 263      4b'20', 4b'a0', 4b'a1', 4b'a2', 4b'a3', 4b'a4', 4b'a5', 4b'a6',
utsa 264      4b'a7', 4b'a8', 4b'5b', 4b'2e', 4b'3c', 4b'28', 4b'2b', 4b'21',
utsa 265      4b'26', 4b'a9', 4b'aa', 4b'ab', 4b'ac', 4b'ad', 4b'ae', 4b'af',
utsa 266      4b'b0', 4b'b1', 4b'5d', 4b'24', 4b'2a', 4b'29', 4b'3b', 4b'5e',
utsa 267      4b'2d', 4b'2f', 4b'b2', 4b'b3', 4b'b4', 4b'b5', 4b'b6', 4b'b7',
utsa 268      4b'b8', 4b'b9', 4b'7c', 4b'2c', 4b'25', 4b'5f', 4b'3e', 4b'3f',
utsa 269      4b'ba', 4b'bb', 4b'bc', 4b'bd', 4b'be', 4b'bf', 4b'c0', 4b'c1',
utsa 270      4b'c2', 4b'60', 4b'3a', 4b'23', 4b'40', 4b'27', 4b'3d', 4b'22',
utsa 271      4b'c3', 4b'61', 4b'62', 4b'63', 4b'64', 4b'65', 4b'66', 4b'67',
utsa 272      4b'68', 4b'69', 4b'c4', 4b'c5', 4b'c6', 4b'c7', 4b'c8', 4b'c9',
utsa 273      4b'ca', 4b'6a', 4b'6b', 4b'6c', 4b'6d', 4b'6e', 4b'6f', 4b'70',
utsa 274      4b'71', 4b'72', 4b'cb', 4b'cc', 4b'cd', 4b'ce', 4b'cf', 4b'd0',
utsa 275      4b'd1', 4b'7e', 4b'73', 4b'74', 4b'75', 4b'76', 4b'77', 4b'78',
utsa 276      4b'79', 4b'7a', 4b'd2', 4b'd3', 4b'd4', 4b'd5', 4b'd6', 4b'd7',
utsa 277      4b'd8', 4b'd9', 4b'da', 4b'db', 4b'dc', 4b'dd', 4b'de', 4b'df',
utsa 278      4b'e0', 4b'e1', 4b'e2', 4b'e3', 4b'e4', 4b'e5', 4b'e6', 4b'e7',
utsa 279      4b'7b', 4b'41', 4b'42', 4b'43', 4b'44', 4b'45', 4b'46', 4b'47',
utsa 280      4b'48', 4b'49', 4b'e8', 4b'e9', 4b'ea', 4b'eb', 4b'ec', 4b'ed',
utsa 281      4b'7d', 4b'4a', 4b'4b', 4b'4c', 4b'4d', 4b'4e', 4b'4f', 4b'50',
utsa 282      4b'51', 4b'52', 4b'ee', 4b'ef', 4b'f0', 4b'f1', 4b'f2', 4b'f3',
utsa 283      4b'5c', 4b'9f', 4b'53', 4b'54', 4b'55', 4b'56', 4b'57', 4b'58',
utsa 284      4b'59', 4b'5a', 4b'f4', 4b'f5', 4b'f6', 4b'f7', 4b'f8', 4b'f9',
utsa 285      4b'30', 4b'31', 4b'32', 4b'33', 4b'34', 4b'35', 4b'36', 4b'37',
utsa 286      4b'38', 4b'39', 4b'fa', 4b'fb', 4b'fc', 4b'fd', 4b'fe', 4b'ff';
utsa 287
utsa 288      do  i = 1 to ccaptr;
utsc   9          if  ebcascoption=2  then $ if want folded to lower case.
utsc  10              cca(i) = ctlc(cca(i));
utsc  11              end if;
utsa 289          cca(i) = ebcasctab(cca(i)+1);
utsa 290          end do;
utsa 291
utsa 292      end subr ebcasc;
utsa 293 ..s37
       1 .=member  inscon
       2      subr inscon( conhc);  $ add constant to ha
       3
       4      $   this routine returns the ha-index of a constant, adding the
       5      $   constant to the ha (and voa) if not yet present.
       6      $   ha-index is returned via conhc.  inputs are global and are
       7      $   ccsyze - no of bits in constant(its size)
       8      $   we use 'add the hash' technique to resolve ha collisions
       9
      10
      11      size  conhc(ps);  $ hash index returned
      12      size  hcode(ws);         $ computed hash code
      13      size  j(ps);             $ ha-index of entry begin examined
      14      size  i(ps);             $ do loop temporary
      15      size  new(voasz);  $ for building new voa entry
      16      size  vb(ps);            $ save position in val array
      17
      18      hcode = ccval(1);
      19      do  i =  2 to  ccvalptr;
      20          hcode = hcode .exor. ccval(i); end do;
      21
      22      hcode = .f. 1, ws/2, hcode .exor. .f. ws/2+1, ws/2, hcode;
      23      haprobe(j, hcode);  $ search the ha
      24          if  (hainuse ha(j) = no) haquit;  $ empty slot found
      25          if  ((var ha(j) = no)  !  (ep ha(j) = 0)) hacont;
      26          if  (const voa(ep ha(j)) = no) hacont;
      27          if  (lextype voa(ep ha(j)) ^= cclt) hacont;
      28          if  (nchars ha(j) ^= ccnchars) hacont;
      29          if  (signbit voa(ep ha(j)) ^= signofcon) hacont;
      30          if  (ccvalptr  ^= vlen voa(ep ha(j))) hacont;
      31          vb = vbeg voa(ep ha(j)) - 1;  $ con 0 origin
      32          do  i =  1 to  ccvalptr;
      33              if  (val(vb+i) ^= ccval(i)) hacont; end do;
      34      $   found
      35          conhc = j;
      36          return;
      37          haend;  $ end ha probe
      38
      39      $   add constant to ha and voa
      40      new = 0;
      41      hainuse ha(j) = yes;  $ show in use
      42      ep ha(j) = voptr;  $ link to voa
      43      var ha(j) = yes;
      44      nchars ha(j) = ccnchars;  ccnchars = 0;
      45      const new = yes;  $ is constant
      46      amode new = (cclt = realtok);
      47      syze new = ccsyze;  $ size in bits
      48      vlen new = ccvalptr;  $ size in words
      49      naym new = j;  $ link to ha
      50      type new = quant;
      51      vbeg new = valptr;
      52      lextype new = cclt;  $ set constant lexical type
      53      signbit new = signofcon ; $ set sign needed for cross-compiler
      54
      55      $   set hascon field if constant is 'safe', i.e., we can evaluate
      56      $   it at compile time.
      57      $   on a resident compiler, any single-word or shorter constant
      58      $   is safe.  on a cross compiler, only short integers and octals
      59      $   are safe.
      60      hascon ha(j) = safeconst(cclt);  $ set if safe constant.
      61      cclt = 0;  $ clear lexical type value
      62      if  (valptr+ccvalptr) > valmax then  $ if val overflow
      63          call gtoflo(valptr+1, valptr, 'val');
      64          end if;
      65      vb = valptr - 1;  $ origin for constant vlu insertion
      66      do  i =  1 to  ccvalptr; val(vb+i) = ccval(i); end do;
      67      valptr = valptr + ccvalptr;  $ update free loc avail in val array
      68      conhc = j;
      69      voa(voptr) = new;  voaup;  $ entry constant itemin voa
      70
      71      end subr inscon;
       1 .=member  sdsnamr
       2      subr sdsnamr(hap);  $ get sds form of ha entry
       3      $   converts name in names array to self defined string and
       4      $   returns it in global variable sdsname
       5      size  hap(ps);    $ ha ptr
       6      size  i(ps);    $ do loop index
       7
       8      slen sdsnamstr =  nchars ha(hap);   $ set length field
       9      if  (nchars ha(hap) = 0) go to ret;
      10      do  i = 1 to (nchars ha(hap) -1) / cpw+1;
      11          .f. nameorg -ws*i, ws, sdsnamstr = names(nayme ha(hap)+i-1);
      12          end do;
      13
      14 /ret/
      15      end subr sdsnamr;
      16
       1 .=member  xsdsnamr
       2      subr xsdsnamr(xhap);  $ get sds form of -xha- entry (same as
       3      $   -sdsnamr- except gets -xha- entry instead of -ha- entry)
       4      size  xhap(ps);  $ -xha- pointer
       5      size  i(ps);     $ do loop index
       6
       7      slen sdsnamstr = xnchars xha(xhap); $ set length
       8      do  i = 1 to (xnchars xha(xhap)-1)/cpw+1;
       9          .f.nameorg-ws*i,ws,sdsnamstr = xnames(xnameptr xha(xhap)+i-1);
      10          end do;
      11
      12
      13      end subr xsdsnamr;
       1 .=member  pdsort
       2      subr pdsort;  $ sort and list procedures and pages.
       3      $   read in list of procedure names and page numbers from
       4      $   reference file; sort by name and print out.
       5
       6      size  i(ps);  $ do-loop index
       7      size  w(ws);
       8      size  l(ps);        $ length of name.
       9      size  lines(ps);  $ number of lines for list.
      10      size  m(ps);           $loop index.
      11      size  haptr(ps);  $ size of packed ha.
      12      size  top(ps);  $ loop indices
      13      size  targ(ps);
      14      size  temp(hasz);  $ temporary for swapping
      15      size  pdcomp(1);   $ function to compare symbols.
      16      size  crfget(ws);   $ read file.
      17
      18      haptr = 0;  namesptr = 0;
      19      $   read in reference file, get procedure names and page numbers.
      20      crbuffptr = crbuffmax;  $ indicate empty buffer to force read.
      21      while 1;
      22          if  (crfget(w) = 0) quit while;
      23          countup(haptr, hamax, 'cr-ha');
      24          ha(haptr) = 0;
      25          ep ha(haptr) = crfget(w);  var ha(haptr) = yes;
      26          nayme ha(haptr) = namesptr + 1;
      27          l = crfget(w);  $ get length of name.
      28          if (l=0) return;    $ cannot handle null name.
      29          nchars ha(haptr) = l;  $ save length.
      30          l = (l-1)/cpw + 1;  $ convert to word count.
      31              if  (l+namesptr) > namesmax  then
      32                  namesptr = namesptr +l;
      33                  countup(namesptr, namesptr, 'cr - names');
      34                  end if;
      35          do  i = 1 to l;
      36              names(namesptr + i) = crfget(w);
      37              end do;
      38          namesptr = namesptr + l;
      39          end while;
      40
      41      if  (haptr = 0)  return;  $ if no procedures.
      42
      43      +*  swap(a,b) = $ macro for swapping, common sort operation
      44          temp = ha(a); ha(a) = ha(b); ha(b) = temp; **
      45
      46      do  i = 2 to haptr; $ make into heap, i is parent.
      47          m = i;
      48          while  m>1;  $ examine parents in turn
      49              if  pdcomp(m/2, m)  quit while; $ if parent no smaller,
      50              swap(m,m/2); $ promote large child
      51              m = m/2;
      52              end while;
      53          end do i;
      54
      55      do  top = haptr to 2 by -1; $ sort subtrees in turn
      56          swap(1,top);  $ extract largest element
      57          m = 1;  $ force remaining subtree to be heap
      58          while  m*2 < top;
      59              if  pdcomp(m*2+1, m*2) & (m*2+1 < top)
      60                  then  targ = m*2+1;
      61                  else  targ = m*2;  end if;
      62              if  pdcomp(targ,m)  then
      63                  swap(m, targ); $ child too big, so exchange
      64              else  quit while;  end if;
      65              m = targ;  $ move to subtree of largest child
      66              end while m;
      67          end do top;
      68
      69      macdrop(swap)
      70      textl(' ') endl  $ blank line
      71      call stitlr(1, 'sorted list of procedures and page numbers.');
      72      ejectl;  $ begin new page.
      73      lines = (haptr+3)/4;   $ number of lines.
      74      do  m = 1 to lines;
      75          i = m;
      76          while i <= haptr;
      77              intl((ep ha(i)))
      78              call sdsnamr(i);
      79              skipl(2)
      80              textl(sdsnamstr);  $ print symbol
      81              skipl(15-slen sdsnamstr)
      82              i = i + lines;
      83              end while;
      84          endl  endl
      85          end do;
      86      endl  $ flushing last few names
      87
      88      end subr pdsort;
       1 .=member  crfget
       2      fnct crfget(w);         $ read word from reference file.
       3      size  crfget(ws);            $ item to read.
       4      size  w(ws);      $ dummy argument.
       5
       6      if  crbuffptr = crbuffmax  then  $ if buffer done, read new one.
       7          call rdrwsio(crfile, iorc, crbuff, 1, crbuffmax);
       8          crbuffptr = 0;
       9          end if;
      10      crbuffptr = crbuffptr + 1;
      11      crfget = crbuff(crbuffptr);
      12
      13      end fnct crfget;
       1 .=member  pdcomp
       2      fnct pdcomp(jarg, karg);  $ compare two symbols.
       3      size  jarg(ps), karg(ps);  $ ha indices of symbols.
       4      size  pdcomp(1);
       5      size  jlen(ps), klen(ps); size minlen(ps);
       6      size  jch(cs), kch(cs);  $  characters.
       7      size  i(ps);            $ loop index.
       8      size  pos(ps);          $ position within name words.
       9      size  jptr(ps),  kptr(ps);  $ nayme values.
      10
      11      jptr = nayme ha(jarg);  kptr = nayme ha(karg);
      12      jch = .f. ws+1-cs, cs, names(jptr);
      13      kch = .f. ws+1-cs, cs, names(kptr);
      14      if  jch ^= kch  then  $ if initial characters differ,
      15          pdcomp = (jch > kch);  $ compare to get result.
      16          return;
      17          end if;
      18      $   must examine rest of symbols, retrieve as sds and compare.
      19      jlen = nchars ha(jarg);  klen = nchars ha(karg);
      20      minlen = jlen; if  (klen < minlen) then minlen = klen; end if;
      21      pdcomp=1;  $ assume j bigger
      22      pos = cpw*cs + 1;
      23      do  i = 1 to minlen;
      24          pos = pos - cs;
      25          jch = .f. pos, cs, names(jptr);
      26          kch = .f. pos, cs, names(kptr);
      27          if  jch ^= kch  then
      28              pdcomp = (jch > kch);
      29              return;
      30              end if;
      31          if  pos = 1  then
      32              pos = cpw*cs + 1;
      33              jptr = jptr + 1;  kptr = kptr + 1;
      34              end if;
      35          end do;
      36      pdcomp = (jlen > klen);  $
      37
      38      end fnct pdcomp;
       1 .=member  getxsds
       2      subr getxsds(hap, str); $ get execution time form of string
       3      $   given sds str, generate minimal-storage representation as sds
       4      $   for use at execution time.  set hap to ha index of generated
       5      $   string.
       6
       7      size  hap(ps);  $ ha index of generated string
       8      size  str(namsz);  $ string to pack
       9      size  i(ps);  $ do loop for ccval copy
      10
      11      ccaptr = slen str;
      12      do  i = 1 to ccaptr;
      13          cca(i) = .ch. i, str;  end do;
      14      cclt = strtok;
      15      call cnvcon;  $ convert constant.
      16      call inscon(hap);
      17      end subr getxsds;
       1 .=member  pshnamr
       2      subr pshnamr(hc, r);  $ hash name and push on arglist
       3      $   hashes name into ha and names array
       4      $   push result on arglist
       5      size  hc(ps);   $ hash code returned
       6      size  r(namsz);   $ sdsname
       7      size  j(ps);   $ do loop index
       8      $   this routine is invoked from macro pushname
       9      do  j = 1 to (slen r + (cpw-1))/cpw;
      10          insnarg(j) = .f. (sorg r) - ws*j, ws, r;
      11          end do;
      12
      13      if  (mod(slen r,cpw)) .f. 1, ws - cs*(mod(slen r, cpw)), insnarg
      14          (j-1) = blankword;   $ set to blank pad like -names-.
      15
      16      insnchars = slen r; call insname(hc);
      17      push(hc);    $ push result onto arglist
      18
      19      end subr pshnamr;
      20
       1 .=member  pshintr
       2      subr pshintr(pcon); $ hash in constant and stack it
       3      size  pcon(ws);  $ constant to insert in ha
       4      size  hai(ps);  $ ha index assigned
       5
       6      ccsyze = .fb. pcon + (pcon=0);  $ set to size.
       7      cclt = dectok; ccval(1)=pcon; ccvalptr = 1;
       8      if  (ccsyze > mws-2) cclt = bittok;  $ for debugging
       9      call inscon(hai); $ hash in constant.
      10      push(hai);
      11
      12      end subr pshintr;
       1 .=member  insname
       2      subr insname(namhc);   $ insert name into ha.
       3
       4      $   this routine returns the ha-index of a name, inserting the
       5      $   inserting the name if not yet present.  global inputs are
       6      $   insnarg - name to insert
       7      $   insnchars - number of characters in name.
       8
       9      size  hcode(ws);  $ hash code of name
      10      size  j(ps);  $ ha-index of entry benng probed
      11      size  namhc(ps);         $ ha-index returned
      12      size  insnwds(ps);    $ number of words
      13      size  i(ps); $ do loop index
      14
      15      hcode = insnarg(1);   $ first word of name
      16      insnwds = (insnchars - 1) / cpw;    $ number of words - 1
      17      if  (insnchars = 0)  insnwds = 0;
      18      do  i = 1 to insnwds;    $ compute hash code
      19          hcode = hcode .ex. insnarg(i + 1);
      20          end do;
      21      hcode = .f. 1, ws/2, hcode .ex. .f. ws/2+1, ws/2, hcode;
      22      haprobe(j, hcode);  $ search the ha
      23
      24          if  (hainuse ha(j) = no) haquit;  $ empty slot found
      25          if  (var ha(j) = no ) hacont;  $ ignore ops
      26          if  (nchars ha(j) ^= insnchars) hacont;
      27          if (nayme ha(j) = 0) hacont;  $ if not a name.
      28          do  i = 0 to insnwds; $ compare names
      29              if  (names(nayme ha(j) + i) ^= insnarg(i+1)) hacont;
      30              end do;
      31          namhc = j;
      32          return;
      33      haend;  $ end ha probe
      34
      35      $   add new name to ha
      36      hainuse ha(j) = yes;  $ show in use
      37      nchars ha(j) = insnchars;    $ number of chars in name
      38      var ha(j) = yes;        $ is variable
      39      nayme ha(j) = namesptr;
      40      do  i = 1 to insnwds + 1;   $ enter name in names array
      41          names(namesptr) = insnarg(i);
      42          countup(namesptr, namesmax, 'insert name');
      43          end do;
      44      namhc = j;
      45
      46      end subr insname;
       1 .=member  insglor
       2      subr insglor(glohc);  $ adds name to global name table
       3      $   this routine returns (via gloha) the index in the global
       4      $   names symbol table of a name, adding the name if it is not yet
       5      $   present.
       6      size  j(ps);            $ do loop index for search
       7      size  i(ps);            $ do loop index
       8      size  hcode(ws);        $ hash code for search
       9      size  glohc(ps);  $ hash code in global array
      10      size  namp(ps);   $ otr to name in names array
      11      size  hwords(ps);    $ number of words in name
      12      $   inputs are transmitted globally, and are
      13      $   insgarg - name to hash
      14      $   insgwds - number of words for name
      15
      16      namp = nayme ha(insgarg);    $ ptr to  names array
      17      hwords = (nchars ha(insgarg) - 1)/cpw;   $ number of words of nm
      18      if  (nchars ha(insgarg) = 0)  hwords = 0;
      19      hcode = names(namp);   $ initialize hcode to first word of name
      20      do  i = 1 to hwords;
      21          hcode = hcode .ex. names(namp + i);
      22          end do;
      23      hcode = .f. 1, ws/2, hcode .ex. .f. ws/2+1, ws/2, hcode;
      24
      25      $   this routine returns the index in xha of a name, adding the
      26      $   name to the xha table if it is not present.
      27      $   the hasing algorith is
      28      $   as described as algorithm 'c' in section 6.4 of knuth, vol 3.
      29      $   note that xha size must be prime
      30      j = mod(hcode, xhamax) + 1;  $ get initial hash code.
      31 /probe/
      32      if  xnchars xha(j) ^= nchars ha(insgarg) go to nomatch;
      33      do  i = 0 to hwords;    $ compare names
      34          if  xnames(xnameptr xha(j) + i) ^= names(namp + i) go to
      35             nomatch;
      36          end do;
      37      glohc = j;    return;    $ match found
      38 /nomatch/
      39      $   no match, look through links, if any
      40      if  xlink xha(j) then  j = xlink xha(j);
      41          go to probe; end if;
      42      if  (xnameptr xha(j) = 0) go to addnew;  $ add new entry.
      43 /findfree/
      44      xhafree = xhafree - 1;  $ look for free xha slot
      45      if  xhafree = 0 then   $ xha full
      46          call ermes(31); call genexit; end if;
      47      if  (xnameptr xha(xhafree)) go to findfree;
      48      xlink xha(j)=xhafree; $link to new slot
      49      j=xhafree;     $ and point to it.
      50 /addnew/
      51      xnchars xha(j) = nchars ha(insgarg);   $ number of characters in
      52      $   name
      53      xnameptr xha(j) = xnamesptr;
      54      do  i = 0 to hwords;     $ copy name from names to xnames
      55          xnames(xnamesptr) = names(namp + i);
      56          countup(xnamesptr, xnamesmax, 'xglobal insert');
      57          end do;
      58      xlink xha(j) = 0;  $ indicate link
      59      glohc = j;              $ hash code found
      60
      61      end subr insglor;
       1 .=member  ifaglor
       2      subr ifaglor(glohc);  $ see if name is global
       3      $   this routine sees if the argument name is a global variable
       4      $   for which access has been granted.  if so, the index in the
       5      $   xha of the variable is returned; otherwise 0 is returned.
       6      $   arguments are passed by the global variables
       7      $   ifaglorname - name of variable
       8      $   ifaglorwds - number of words in name
       9
      10      size  i(ps);    $ do loop var
      11      size  namp(ps);    $ ptr to names array
      12      size  hwords(ps);     $ number of words of name
      13      size  j(ps);  $ do loop index
      14      size  hcode(ws);        $ hash code of name
      15      size  glohc(ps);        $ha index returned
      16      size  hap(ps);           $ ha index of nameset name
      17      size  xnp(ps);           $ index in xnames of nameset name
      18
      19      namp = nayme ha(ifaglorname);   $ ptr to names array
      20      hwords = (nchars ha(ifaglorname) - 1)/cpw;  $ nwords-1.
      21      hcode = names(namp);  $ first word of name.
      22      do  i = 1 to hwords;
      23          hcode = hcode .ex. names(namp+i);
      24          end do;
      25
      26      hcode = .f. 1, ws/2, hcode .ex. .f. ws/2+1, ws/2, hcode;
      27      j = mod(hcode, xhamax) + 1;  $ set initial hash code.
      28 /probe/
      29      if  xnchars xha(j) ^= nchars ha(ifaglorname) go to nomatch;
      30      if  xnames(xnameptr xha(j)) ^= names(namp) go to nomatch;
      31      do  i = 1 to hwords;    $ compare rest of name
      32          if  xnames(xnameptr xha(j) + i) ^= names(namp + i)
      33               go to nomatch;
      34          end do;
      35
      36      $   if we have been looking for possible builtin function name,
      37      $   we return  builtin function code, not xha position.
      38      if  bifxhasearch  then
      39          glohc = xhabif xha(j);
      40          return;  end if;
      41
      42      $   name found, see if access granted
      43      if  (nlno xha(j) = 0)  go to ret;
      44      if  (nlblk nl(nlno xha(j)) = 0) go to ret;
      45      $   if access not granted to variable, return.
      46      $   if access granted, enter nameset name into ha if not already
      47      $   there, and set -mbused- bit to indicate that nameset used
      48      $   in current routine.
      49
      50      if  (.f. nlblk nl(nlno xha(j)), 1, accesstab = no) go to ret;
      51
      52      glohc = j;  $ access granted, set glohc to xha index
      53      mbused mba(nlblk nl(nlno xha(j))) = yes;  $ nameset member used in
      54      if  (mbha mba(nlblk nl(nlno xha(j)))) go to done;  $ nameset name
      55      j = mbxha mba(nlblk nl(nlno xha(j)));  $ get xha index of conta
      56      xnp = xnameptr xha(j) - 1;
      57      do  i = 1 to (xnchars xha(j) - 1)/cpw + 1;
      58          insnarg(i) = xnames(xnp+i);
      59          end do;
      60
      61      insnchars = xnchars xha(j);
      62      call insname(hap);
      63      mbha mba(nlblk nl(nlno xha(glohc))) = hap;  $ set -ha- index.
      64      return;
      65
      66 /nomatch/  $ no match found. try next entry if there is one
      67      j = xlink xha(j);
      68      if  (j) go to probe;
      69
      70 /ret/
      71      glohc = 0;  $ failure.
      72
      73 /done/
      74      end subr ifaglor;
       1 .=member  advstr
       2      subr advstr(str, hc);  $ advance name and hash in
       3      $   this routine is given string naming current local variable
       4      $   or local label generation string.  the string is four
       5      $   characters, of which the last two are alphabetic.  the routine
       6      $   advances the name to next one in lexicographic order, eg,
       7      $   from -aa- to -zz-.  compilation is aborted if attempt made to
       8      $   exceed -zz-.
       9      size  str(sds(4));  $ string to davance
      10      size  hc(ps);   $ hash code computed
      11      size  ci(ps);  $ character position
      12      size  alphabet(sds(26));
      13            data alphabet = 'abcdefghijklmnopqrstuvwxyz';
      14
      15      ci =  (.s. 4, 1, str) .in. alphabet;
      16      if  ci<26 then  $ if last character can be advanced
      17          .ch. 4, str = .ch. ci+1, alphabet; $ pick next character
      18      else   $ try to advance third character, restart fourth at 'a'
      19          ci = (.s.3,1,str) .in. alphabet;
      20          if  ci<26 then
      21              .ch. 3, str = .ch. ci+1,alphabet; .ch.4,str=1ra;
      22          else  countup(ci  ,26, 'advstr - name overflow'); end if;
      23      $   note that above countup will abort program execution
      24          end if;
      25      pushname(hc, str);  $ hash in name to ha and names
      26      $   pushname has added item to arglist, so remove from arglist
      27      argptr = argptr-1;
      28      namintern ha(hc) = yes;  $ set internal name flag
      29
      30      end subr advstr;
       1 .=member  assembl
       2      subr assembl;  $ write tables on -voa- file
       3      $   write tables onto -voa- file for used by code generator.
       4      $   write entries in 'frames', indicating type and length of each
       5      $   frame.  if argument non-zero, dump symbol table.
       6      size  i(ws);
       7      size  nzwds(ps);    $ number of zero words in ha
       8      size  haent(hasz);  $ temporary copy of ha entry
       9      if  asmvoadump = yes then
      10          call tabdump(1, voptr, 1); end if;
      11      $   if first procedure is to be suppressed, do not write out.
      12      if  (nsubrs=1)&(sfp_opt) then return; end if;
      13      if  (voawrt = no) return;  $ not writing voa file
      14
      15      vof = 0;  $ routine header
      16      vof_code  vof = voaasm_code;  $ indicate routine header
      17      vof_listcode vof = listingcode;  $ default code list mode at start
      18      vof_asmarg  vof = 0;
      19      vof_init  vof = voafnct;
      20      vof_lablistptr  vof = lablistptr;
      21      vof_sub1  vof = subinfo(1);  $ copy subinfo array
      22      vof_sub2  vof = subinfo(2);
      23      vof_sub3  vof = subinfo(3);
      24      vof_subrargs vof = argct; $ indicate number of arguments.
      25      vof_ha0 vof = ha_0; $ ha index of constant 0.
      26      vof_ha1 vof = ha_1; $ ha index of constant 1.
      27      vofhdrseq = vofhdrseq+1;  vof_hdrseq vof = vofhdrseq;
      28      write voafile, vof;
      29
      30      vof = 0;
      31      call putvhdr(voa, 1, voptr, voasz, voa_code); $ write voa
      32      write voafile, voa(1) to voa(voptr);
      33
      34      call putvhdr(names, 1, namesptr, ws, names_code); $ write -names
      35      write voafile, names(1) to names(namesptr);
      36
      37      call putvhdr(xarg, 1, xargptr, xargsz, xarg_code);
      38      write voafile,  xarg(1) to xarg(xargptr);
      39
      40      call putvhdr(mba, 1, mbaptr, mbasz, mbacode);
      41      write voafile, mba(1) to mba(mbaptr);
      42
      43      call putvhdr(val, 1, valptr, ws, val_code); $ write -val-
      44      write voafile, val(1) to val(valptr);
      45
      46      $   now write out ha.  since ha hashed, we pack ha into
      47      $   linear array, recording in field -zerents- the number
      48      $   of empty (all 0) entries preceeding each non-zero entry.
      49      $   an extra-field is written in header, giving alvue of hamax as
      50      $   usedin writer, so asm can check validity of hamax val on read.
      51      $   now pack ha, hp points to last value in packed form
      52      size  hp(ps);  $  alst entry in packed ha
      53      nzwds = 0;  $ number of zero entries before current one
      54      hp = 0;
      55      do  i = 1 to hamax;
      56          if  var ha(i) = 0  $ ignore empty and non-variables.
      57          then  nzwds = nzwds + 1;
      58          else  zerents ha(i) = nzwds; nzwds = 0;
      59                hp = hp+1;  ha(hp) = ha(i);  $ move done packed
      60                end if;
      61          end do;
      62      $   now write remaining zero entries at top of ha
      63      if  nzwds then
      64          haent = 0;  zerents haent = nzwds-1;
      65          hp = hp + 1;  ha(hp) = haent;  end if;
      66      vof = 0; $ clear frame
      67      vof_hamax vof = hamax; $ indicate -hamax- in wrtie phase
      68      vof_code vof = ha_code; $ code for array
      69      vof_es vof = hasz; $ entry size
      70      vof_lo vof = 1;   $ first entry
      71      vof_hi vof = hp; $ last entry
      72      vofhdrseq = vofhdrseq+1;  vof_hdrseq vof = vofhdrseq;
      73      write voafile, vof;  $ write header frame.
      74      write voafile, ha(1) to ha(hp);
      75
      76      vof = 0;  vof_code vof = eos_code;
      77      vofhdrseq = vofhdrseq+1;  vof_hdrseq vof = vofhdrseq;
      78      write voafile, vof;  $ write frame marking end of routine
      79
      80      end subr assembl;
       1 .=member  putvhdr
       2      subr putvhdr(ara, lo, hi, es, acode); $ put array to voa-file
       3      $   write ara(lo) to ara(hi) to voa-file.  entries are -es- bits
       4      $   long.  -acode- is integer code for array.
       5      $   construct header frame and call -wtrvoahdr- to write array dat
       6
       7      size  ara(ws);  $ true size is -e-s.  is array to write
       8      size  lo(ps);   $ first entry to write
       9      size  hi(ps);   $ last entry to write
      10      size  acode(ps); $ array code
      11      size  es(ps);  $ entry size in bits
      12      vof = 0;  $ clear header frame
      13      vof_code vof = acode;
      14      vof_lo vof = lo;  vof_hi vof = hi;
      15      vof_es vof = es;  $ entry size in bits
      16      vofhdrseq = vofhdrseq+1;  vof_hdrseq vof = vofhdrseq;
      17      write voafile, vof;
      18
      19      end subr putvhdr;
       1 .=member  ermet
       2      subr ermet; $  syntactic error message output routine
       3      $   issue error message after checking for unexpected error
       4      $   number.  call -lstlin- to list last line read if it has not
       5      $   yet been listed.  increment error total count -nerrors-.
       6      size  synstr(.sds. 15);   $ error message text.
       7
       8      argptr = 1; opstackp = 0;  $ reset arrays.
       9
      10      $   if this was in the middle of an opener for an statement other
      11      $   than an -if- statement, flush this -csa- entry.
      12      if  (toknum csa(csaptr) = 0 & cstype csa(csaptr) ^= cstype_if)
      13          csaptr = csaptr-1;
      14
      15      terml(yes);  $ give output to terminal too
      16      call lstlin;
      17      nerrors = nerrors + 1;  $ update error count
mgfc  15 .+s10    error_s10;  $ give s10 error character.
      18      textl(error_notice)
      19
      20      if  ermsgno<1 ! ermsgno>parseerrmax  then
      21          tintl('syntactic error',ermsgno) endl
      22          go to return;
      23      else
      24          go to e(ermsgno) in 1 to parseerrmax;
      25          end if;
      26
      27      +*  et (erform, ertext) =
      28      call ermlst(erform, ertext); go to return; **
      29      $   new parser syntactic error messages
      30 / e(1)  /
      31 / e(2)  /
      32 / e(3)  /
      33      $   these three error messages occur for many extractors.  we
      34      $   must therefore print out the correct extractor.
      35      if  parsereg(3) = 2 then
      36          synstr = '.f. i1, i2, ';
      37      elseif  parsereg(3) = 3 then
      38          synstr = '.e. i1, i2, ';
      39      elseif  parsereg(3) = 4 then
      40          synstr = '.s. i1, i2, ';
      41      else   $ must be 5.
      42          synstr = '.ch. i1, ';
      43          end if;
      44
      45      $   now print appropriate text.
      46      if  ermsgno = 3 then
      47          et(synstr, 'expression')
      48      elseif  ermsgno = 2 then
      49          et(synstr, 'comma')
      50      else  $ must be 1.
      51          et(synstr !! 't', 'term for extraction')
      52          end if;
      53
      54 / e(4)  / et('', 'control format item')
      55 / e(5)  / et('', 'data format item')
      56 / e(6)  / et('', 'data format item')
      57 / e(7)  / et('', 'data item in i/o list')
      58 / e(8)  / et('', 'expression after binary operator')
      59 / e(9)  / et('', 'expression in format item')
      60 / e(10) / et('', 'file attribute in ''file'' statement')
      61 / e(11) / et('', 'parameter in ''monitor'' statement')
      62 / e(12) / et('', 'right parenthesis in format item')
      63 / e(13) / et('', 'semicolon')
      64 / e(14) / et('', 'statement to begin with name')
      65 / e(15) / et('', 'term after unary operator')
      66 / e(16) / et('', 'valid statement beginning')
      67 / e(17) / et('/l(c1)/', 'expression')
      68 / e(18) / et('/l(c1)/', 'right parenthesis')
      69 / e(19) / et('/l1/', 'closing slash')
      70 / e(20) / et('/l1/', 'label name')
      71 / e(21) / et('(e1)', 'expression')
      72 / e(22) / et('(e1)', 'right parenthesis')
      73 / e(23) / et('(n1,...,n9)', 'right parenthesis')
      74 / e(24) / et('access n1', 'name')
      75 / e(25) / et('assert e1', 'expression')
      76 / e(26) / et('attr = val', 'equal sign')
      77 / e(27) / et('attr = val', 'expression')
      78 / e(28) / et('call n1', 'procedure name')
      79 / e(29) / et('call n1(e1,...,e9)', 'expression')
      80 / e(30) / et('call n1(e1,...,e9)', 'right parenthesis')
      81 / e(31) / et('check index', '''index''')
      82 / e(32) / et('data n1 = c1', 'equal sign')
      83 / e(33) / et('data n1 = c1', 'expression')
      84 / e(34) / et('data n1 = c1', 'name')
      85 / e(35) / et('data n1(c1) = c2', 'index expression')
      86 / e(36) / et('data n1(c1) = c2', 'right parenthesis')
      87 / e(37) / et('data v1 = c1(c2)', 'repetition expression')
      88 / e(38) / et('data v1 = c1(c2)', 'right parenthesis')
      89 / e(39) / et('dims n1(c1)', 'expression')
      90 / e(40) / et('dims n1(c1)', 'left parenthesis')
      91 / e(41) / et('dims n1(c1)', 'name')
      92 / e(42) / et('dims n1(c1)', 'right parenthesis')
      93 / e(43) / et('do v1 = e1 to e2', '''to''')
      94 / e(44) / et('do v1 = e1 to e2', 'equal sign')
      95 / e(45) / et('do v1 = e1 to e2', 'initial expression')
      96 / e(46) / et('do v1 = e1 to e2', 'limit expression')
      97 / e(47) / et('do v1 = e1 to e2', 'loop variable name')
      98 / e(48) / et('do v1 = e2 to e2 by e3', 'expression after ''by''')
      99 / e(49) / et('elseif e2 then', '''then''')
     100 / e(50) / et('elseif e2 then', 'expression')
     101 / e(51) / et('e1,...,e9', 'expression')
     102 / e(52) / et('file fid', 'expression')
     103 / e(53) / et('filestat(fid, scode)', 'comma')
     104 / e(54) / et('filestat(fid, scode)', 'expression')
     105 / e(55) / et('filestat(fid, scode)', 'keyword')
     106 / e(56) / et('filestat(fid, scode)', 'left parenthesis')
     107 / e(57) / et('filestat(fid, scode)', 'right parenthesis')
     108 / e(58) / et('fnct n1', 'procedure name')
     109 / e(59) / et('get formlist', 'format list')
     110 / e(60) / et('go to n1(e1) in c1 to c2', '''in''')
     111 / e(61) / et('go to n1(e1) in c1 to c2', '''to''')
     112 / e(62) / et('go to n1(e1) in c1 to c2', 'expression')
     113 / e(63) / et('go to n1(e1) in c1 to c2', 'limit expression')
     114 / e(64) / et('go to n1(e1)', 'expression')
     115 / e(65) / et('go to n1(e1)', 'right parenthesis')
     116 / e(66) / et('go to sl', '''to''')
     117 / e(67) / et('go to sl', 'label name')
     118 / e(68) / et('goby (e1)(l1,...,l9)', 'expression')
     119 / e(69) / et('goby (e1)(l1,...,l9)', 'right parenthesis')
     120 / e(70) / et('goby n1(l1,...,l9)', 'label name')
     121 / e(71) / et('goby n1(l1,...,l9)', 'left parenthesis')
     122 / e(72) / et('goby n1(l1,...,l9)', 'name')
     123 / e(73) / et('goby n1(l1,...,l9)', 'right parenthesis')
     124 / e(74) / et('if e1', 'expression')
     125 / e(75) / et('monitor limit = e1', 'equal sign')
     126 / e(76) / et('monitor limit = e1', 'expression')
     127 / e(77) / et('nameset n1', 'name')
     128 / e(78) / et('n1,...,n9', 'name')
     129 / e(79) / et('prog n1', 'procedure name')
     130 / e(80) / et('put formlist', 'format list')
     131 / e(81) / et('read fid', 'expression')
     132 / e(82) / et('real n1', 'name')
     133 / e(83) / et('rewind fid', 'expression')
     134 / e(84) / et('size n1(c1)', 'expression')
     135 / e(85) / et('size n1(c1)', 'left parenthesis')
     136 / e(86) / et('size n1(c1)', 'name')
     137 / e(87) / et('size n1(c1)', 'right parenthesis')
     138 / e(88) / et('subr n1', 'procedure name')
     139 / e(89) / et('subr n1(n2,..)', 'parameter name')
     140 / e(90) / et('trace type', 'type of trace statement')
     141 / e(91) / et('until e1', 'expression')
     142 / e(92) / et('v1 = e1', 'equal sign')
     143 / e(93) / et('v1 = e1', 'expression')
     144 / e(94) / et('v1 = e1', 'assignment target')
     145 / e(95) / et('v1(e1) to v1(e2)', 'name after ''to''')
     146 / e(96) / et('v1(e1)', 'expression')
     147 / e(97) / et('v1(e1)', 'right parenthesis')
     148 / e(98) / et('v1(i1) = e1', 'right parenthesis')
     149 / e(99) / et('v1(i1) = e1', 'subscript expression')
     150 / e(100)/ et('while e1', 'expression')
     151 / e(101)/ et('write fid', 'expression')
     152 / e(102)/
     153 / e(103)/
     154      $   these two error messages are converted to errors 2 and 3.
     155      ermsgno = ermsgno - 100;  $ convert error number.
     156      parsereg(3) = parsereg(7);  $ get type of extractor.
     157      go to e(2);   $ process like errors 2 and 3.
     158
     159 /return/
     160      call squeeze; $ list recent tokens
     161
     162      if  nerrors > pelvalue  then  $ quit if too many errors.
mgfc  16          endl
mgfc  17 .+s10    error_s10;  $ give s10 error character.
mgfc  18          textl(error_notice)
     164          textl('error limit of ') intl(pelvalue)
     165          textl(' exceeded. compilation aborted.') endl endl
     166          call genexit; end if;
     167
     168      terml(no);  $ done with terminal output
     169
     170      macdrop(parseerrmax)
     171      end subr ermet;  $  of syntactic error printer
       1 .=member  ermlst
       2      subr ermlst(erform,ertext);  $ list error message fragment
       3      $   this routine, called only from ermet, lists part of syntactic
       4      $   error message.
       5      size  erform(ws+1);  $ text giving position in parse
       6      size  ertext(ws+1);  $ text for diagnostic
       7
       8      textl('expect ') textl(ertext)
       9      if  slen erform then   $ there is a construct text.
      10          textl(' in construct ''') textl(erform) textl('''.')
      11      else
      12          textl('.')
      13          end if;
      14
      15      endl
      16
      17      end subr ermlst;
       1 .=member  ermes
       2      subr ermes(n);  $ semantic error message routine
       3      size  types(.sds. 7);   dims types(cstypes);
       4      data  types(cstype_nameset) = 'nameset':
       5            types(cstype_prog)    = 'prog':
       6            types(cstype_subr)    = 'subr':
       7            types(cstype_fnct)    = 'fnct':
       8            types(cstype_do)      = 'do':
       9            types(cstype_while)   = 'while':
      10            types(cstype_until)   = 'until':
      11            types(cstype_if)      = 'if';
      12
      13      +*  ender = go to return;**
      14      $   error message subroutine
      15
      16      size  n(ps);  $ error number
      17
posa   1      $   avoid comparand error message for m11 for now.
posa   2      if  ((n=5) & (targetmachine=m11))  return;
      18      terml(yes);  $ write error message to terminal file
      19      call lstlin;  $ list input line.
dst   28      if  (n=5 & targetmachine=m11) ! n=15 ! n=70 ! n=71 then
mgfc  19 .+s10    warn_s10;  $ give s10 warn character.
      21          textl(warning_notice)  nwarnings = nwarnings + 1;
      22      else
mgfc  20 .+s10    error_s10;  $ give s10 error character.
      23          textl(error_notice)
      24          nerrors = nerrors + 1;
      25          end if;
      26
dss   51      +*  maxerrors = 71 **  $ maximum number of errors
      28      if (n < 1 ! n > maxerrors) go to l(1);
      29      go to l(n) in 1 to maxerrors;
      30      $   we allow room for up to 60 error messages
      31      $   unused slots branch to l(1), to list short text and number.
      32 / l( 1) /  textl('semantic error number ') intl(n) ender
      33 / l( 2) /  textl('expect data for ''') naml(ermesarg)
      34      textl(''' to be in routine defining it.') ender
      35 / l( 3) /  go to l(1);
      36 / l( 4) /  textl('expect positive value.') ender
dst   29 / l( 5) /  textl('comparison operand is multi-word') ender;
      38 / l( 6) /  textl('expect positive replication value.') ender
      39 / l( 7) /  if  preludefg then
      40                  ntexterr = yes;
      41                  textl('expect subr, fnct, or eof to immediately ')
      42                  textl('follow routine.')
      43            else
      44                  textl('expect ''') naml(ermesarg)
      45                  textl(''' to be sized.')
      46                  end if;
      47              ender
      48 / l(8) /  textl('expect less than') intl(xargmax+1)
      49              textl(' parameters or data statement entries.') ender
      50 / l(9) /  textl('s-type strings not valid on selected target machine.')
      51          ender
ldsd  34 / l(10) /  textl('expect real constant to be in range.') ender
      53 / l(11) /  go to l(1);
      54 / l(12) /  textl('expect inputs to string comparison not to be reals.')
      55          ender
      56 / l(13) /  textl('expect constant with size less than') intl(szmax+1)
      57      textl('.') ender
      58 / l(14) /  textl('expect label to be defined only once.') ender
pre    1 / l(15) /  textl('expect no logical expressions on reals.')endl return;
      61 / l(16) /  textl('expect limit value to be in range.') ender
      62 / l(17) /  textl('expect nameset ''') naml(ermesarg)
      63              textl(''' to be defined.') ender
      64 / l(18) /  textl('expect dimension to be less than ') intl(dimsmax+1)
      65              textl('.') ender
      66 / l(19) /  if  (preludefg) go to l(7);
      67          textl('expect function ''') naml(ermesarg)
      68              textl(''' to be sized.') ender
      69 / l(20) /
      70 / l(21) /  go to l(1);
      71 / l(22) /  textl('expect file attribute to be defined only once.')
      72          ender
      73 / l(23) /  textl('expect recognizable file attribute.') ender
      74 / l(24) /  textl('expect control format item.') ender
      75 / l(25) /  textl('expect data format item.') ender
      76 / l(26) /  textl('namelist format not valid on input.') ender
      77 / l(27) /  textl('expect nameset format to be applied to variable.')
      78          ender
      79 / l(28) /  textl('expect function argument ''') naml(ermesarg)
      80          textl(''' not to be changed.') ender
      81 / l(29) /  go to l(1);
      82 / l(30) /  textl('expect ''') naml(ermesarg) textl(''' to be in ')
      83          textl('argument list only once.') ender
      84 / l(31) /  textl('-xha- is full.  compilation aborted.') ender
      85 / l(32) /  textl('expect size value less than ') intl(szmax+1)
      86          textl('.') ender
      87 / l(33) /  textl('expect ''') naml(ermesarg)
      88              textl(''' to be a function.') ender
      89 / l(34) /  textl('expect ''') naml(ermesarg)
      90              textl(''' to be a subroutine.') ender
      91 / l(35) /  textl('expect ''='' after ''^'' in binary operation.')
      92          ender
      93 / l(36) /  go to l(1);
      94 / l(37) /  textl('expect ''quit'' to refer to loop') ender
      95 / l(38) /  textl('expect ''cont'' to refer to loop') ender
      96 / l(39) /  go to l(1);
      97 / l(40) /    textl('expect ''') naml(ermesarg)
      98          textl(''' to be an array.') ender
      99 / l(41) /  textl('expect ''then'' in ''if'' statement.') ender
     100 / l(42) /  textl('expect constant expression.') ender
     101 / l(43) /  textl('expect tokens to match those in ''')
     102 /csatell/
     103      textl(types(cstype csa(ermesarg))) textl(''' at line')
     104      intl(firstst csa(ermesarg)) textl('.') ender
     105 / l(44) /  textl('expect operands of same arithmetic mode.') ender
     106 / l(45) /  textl('expect constant mode data statement.') ender
     107 / l(46) /  textl('expect datum in io statement.') ender
     108 / l(47) /  textl('expect label index to be in range.') ender
     109 / l(48) /  textl('expect labels in ''go to'' to be in ascending order')
     110              ender
     111 / l(49) /  textl('expect ''') naml(ermesarg)
     112          textl(''' to be used as an array.') ender
     113 / l(50) /  textl('expect ''then'' or ''elseif'' before ''elseif''')
     114          ender
     115 / l(51) /  textl('expect ''') naml(ermesarg)
     116          textl(''' to be global.') ender
     117 / l(52) /  textl('-ha- is full.  compilation aborted.') ender
     118 / l(53) /  textl('expect operands to .pad. to be constants.') ender
     119 / l(54) /  textl('expect ''') naml(ermesarg)
     120          textl(''' to be dimensioned only once.') ender
     121 / l(55) /  go to l(1);
     122 / l(56) /  textl('expect ''') naml(ermesarg)
     123              textl(''' to be sized only once.') ender
     124 / l(57) /  textl('expect only monitoring statements in interlude.')
     125      ender
     126 / l(58) /  textl('name list not valid in this context.') ender
     127 / l(59) /  textl('expect main program not to have arguments.')  ender
     128 / l(60) /  textl('expect ''end'' for ''') go to csatell;
     129 / l(61) /  textl('extraneous ''end'' statement.') ender
     130 / l(62) /  textl('expect only one ''else'' per ''if''.') ender
     131 / l(63) /  textl('invalid combination of file attributes in ''file'' ')
     132          textl('statement.') ender
     133 / l(64) /  textl('expect arguments to .cc. to be strings.') ender
     134 / l(65) /  textl('-arglist- overflow.  compilation aborted.') ender
     135 / l(66) /  textl('function ''') naml(ermesarg)
     136          textl(''' used as variable.') ender
     137 / l(67) /  textl('expect only one dimensional array references.') ender
     138 / l(68) /  textl('expect correct number of arguments to built-in ')
     139      textl('function.') ender
     140 / l(69) /  textl('reals not supported for selected target machine.')
     141      ender
dss   52 / l(70) /  textl('temporary size too large, size truncated.') ender
dss   53 / l(71) /  textl('subscript size exceeds') intl(cis_opt) ender
     142 /return/
     143      endl
     144      call squeeze; $ list recent tokens
     145      if  nerrors>pelvalue  then  $ quit if too many errors.
mgfc  21          endl
mgfc  22 .+s10    error_s10;  $ give s10 error character.
mgfc  23          textl(error_notice)
     147          textl('error limit of ')  intl(pelvalue)
     148          textl(' exceeded. compilation aborted.') endl endl
     149          call genexit; end if;
     150      terml(no);  $ done with terminal output
     151
     152      macdrop(maxerrors)
     153      end subr ermes;
       1 .=member  ermey
       2      subr ermey(n);  $ terminal error message routine
       3      size  n(ps);  $ error number
       4
       5      terml(yes);  $ write output to terminal
       6      if  n ^= 9 then  $ not -nextok- error
       7          call lstlin;  $ list input line.
       8          end if;
       9      textl(system_notice)
      10      +*  maxerrors = 9 **
      11      if  (n < 1 ! n > maxerrors) go to l(1);
      12      go to l(n) in 1 to maxerrors;
      13      +*  em = go to exit; **
      14 / l(1) /  textl('terminal error message number ') intl(n) em
      15 / l(2) /  textl('parse control stack underflow') em
      16 / l(3) /  textl('-bronlit- index out of range') em
      17 / l(4) /  textl('compiler not handling expressions correctly') em
      18 / l(5) /  textl('-opstack- underflow - expression') em
      19 / l(6) /  textl('-opstack- underflow - operator') em
      20 / l(7) /  textl('logic error in -gendat-') em
      21 / l(8) /  textl('illegal constant type') em
      22 / l(9) /  textl('bad token lexical type') em
      23      macdrop(em)  macdrop(maxerrors)
      24 /exit/
      25      endl  call squeeze;
      26      terml(no);  $ done with output to terminal
      27      call genexit;  $ abort - fatal error
      28
      29      end subr ermey;
      30
      31
       1 .=member  ctcat
       2      subr ctcat(resat, a1, a2);
       3      $   routine to check for .cc. on constants
       4      size  a1(ps), a2(ps), resat(ps);  $ inputs and output
       5      size  arg(ps); dims arg(2);  $ array of arguments
       6      size  l(ps); dims l(2);      $ array of lengths
       7      size  i(ps), j(ps);   $ do loop variables
       8
       9      arg(1) = a1; arg(2) = a2; resat = 0;  $ set initial values
      10      do  i = 1 to 2;  $ process each argument
      11          if  (var ha(arg(i)) = no) go to ret;  $ no good if temp
      12          if  (const voa(ep ha(arg(i))) = no) go to ret;  $ not const
      13          if  (lextype voa(ep ha(arg(i))) ^= strtok) go to ret;
      14          l(i) = nchars ha(arg(i));  $ set string length
      15          end do;
      16
      17      if  l(1)*l(2) = 0 then   $ if either null, return other
      18          if  (l(1) = 0) resat = a2;
      19          if  (l(2) = 0) resat = a1;
      20          go to ret;
      21          end if;
      22
      23      $   if result too long, return not constant
      24      if  (l(1)+l(2) > toklenmax-cpw) go to ret;
      25
      26      $   now do concatenation
      27      ccaptr = 0;  $ start at begining of array
      28      do  i = 1 to 2;  $ place each string into array
      29          $   first, move into -sdsnamstr-
      30          do  j = 1 to (l(i)-1)/cpw+1; $ move a word at a time
      31              .f. nameorg-ws*j, ws, sdsnamstr =
      32                  val(vbeg voa(ep ha(arg(i)))+j-1);
      33              end do;
      34          slen sdsnamstr = l(i);  $ set length of string
      35          $   now, unpack into -cca-
      36          do  j = 1 to l(i);
      37              ccaptr = ccaptr+1; cca(ccaptr) = .ch. j, sdsnamstr;
      38              end do;
      39          end do i;
      40
      41      $   finally, build and hash in new constant
      42      cclt = strtok; call cnvcon;
      43      call inscon(resat);
      44
      45 /ret/
      46      end subr ctcat;
      47
       1 .=member  squeeze
       2      subr squeeze; $ list recent tokens
       3      size  i(ps);  $ index in lexlist
       4      size  n(ps);  $ number listed
       5      size  l(ps);          $ number of chars to list.
       6      +*  dstrlen =  $ maximum number of chars to list.
vax  210 .+s32    8
       7 .+s37    8
utsa 294 .+s47    8
       8 .+s66    10
dso  111 .+s10    12  $ 2*cpw
      10          **
      11      size  dstr(.sds. dstrlen);  $ display string.
      12
      13      dstr = '' .pad. dstrlen;  $ initialize.
      14
      15      skipl(15) textl('last few tokens: ')
      16      i = lexlistptr-1; $ set to start
      17      n = 0;
      18      while 1;
      19          i = (i+1) & (lexlistmax-1); $ bump i, modulo lexlistmax
      20          n = n+1; if (n>lexlistmax) quit while;
      21          if  (lexlist(i+1) = 0) cont while;  $ ignore if not set
      22          charl(1r );
      23          l = lexleng(i+1);  if (l>dstrlen)  l = dstrlen;
      24          slen dstr = l;
      25          .f. (.sds. dstrlen)+1-ws, ws, dstr = lexlist(i+1);
dso  112 .+s10.
dso  113          $   on s10,  use up two lexlist entries.
dso  114          i = (i+1) & (lexlistmax-1);  n = n + 1;
dso  115          .f. (.sds. dstrlen)+1-2*ws, ws, dstr = lexlist(i+1);
dso  116 ..s10
vax  211 .+s32.   $   on s32, use up to two lexlist entries.
vax  212          i = (i+1) & (lexlistmax-1);  n = n + 1;
vax  213          .f. (.sds. dstrlen)+1-2*ws, ws, dstr = lexlist(i+1);
vax  214 ..s32
      26 .+s37.   $   on s37, use up to two lexlist entries.
      27          i = (i+1) & (lexlistmax-1);  n = n + 1;
      28          .f. (.sds. dstrlen)+1-2*ws, ws, dstr = lexlist(i+1);
      29 ..s37
utsa 295 .+s47.   $   on s47, use up to two lexlist entries.
utsa 296          i = (i+1) & (lexlistmax-1);  n = n + 1;
utsa 297          .f. (.sds. dstrlen)+1-2*ws, ws, dstr = lexlist(i+1);
utsa 298 ..s47
      30          textl(dstr)
      31          end while;
      32      endl
      33      listl(listsw=no) endl listl(yes)
      34
      35      macdrop(dstrlen);
      36      end subr squeeze;
       1 .=member  findcsa
       2      subr findcsa(csap, typ);  $ find -csa- entry.
       3      $   this routine finds the -csa- pointer whose opener most closely
       4      $   matches the tokens on the statement being scanned.  -typ- is n
       5      $   not set for -quit- and -cont- where only a loop is being
       6      $   searched for.
       7      size  csap(ps);     $ return index.
       8      size  typ(1);       $ type parameter.
       9      size  csap1(ps);    $ approximate match.
      10      size  i(ps), j(ps); $ temporaries.
      11      size  org(ps);      $ origin in -csatoks-.
      12      size  toks(ps), typs(1);   $ opener information.
      13      dims  toks(cstypes), typs(cstypes);
      14
      15      +*  tt(cst, tok, tp) =   $ initialize -toks- and -typs-.
      16          toks(cst) = tok:  typs(cst) = tp **
      17
      18      data    $   initialize tables.
      19          tt(cstype_subr,    lc_subr,   yes):
      20          tt(cstype_fnct,    lc_fnct,   yes):
      21          tt(cstype_prog,    lc_prog,   yes):
      22          tt(cstype_while,   lc_while,   no):
      23          tt(cstype_until,   lc_until,   no):
      24          tt(cstype_do,      lc_do,      no):
      25          tt(cstype_if,      lc_if,     yes):
      26          tt(cstype_nameset, lc_nameset,yes);
      27
      28      macdrop(tt)
      29
      30      size  lc(ps);       $ literal code of first token.
      31      size  ntoks(ps);    $ number of tokens after first.
      32      size  stoks(ws);  dims stoks(5);  $ succeding tokens.
      33
      34      $   first, show that there were no matches.
      35      csap = 0;  csap1 = 0;  $ clear both pointers.
      36
      37      $   next, get first token.
      38      if  (keeptok = no) call nextok;  $ get next token.
      39      lc = toklc;  $ save its literal code.
      40      ntoks = 0; $ show no more tokens yet.
      41      if  lc ^= lc_semicolon then  $ scan for more if not end.
      42          do  ntoks = 1 to 5;   $ scan forwards.
      43              call nextok;  $ get next token.
      44              stoks(ntoks) = tokara(1);  $ get first token word.
      45              if  (toklc = lc_semicolon) quit do;  $ stop at semicolon.
      46              end do;
      47
      48          ntoks = ntoks-1;  $ allow for last.
      49          end if;
      50
      51      do  i = csaptr to 1 by -1;  $ now scan looking for match.
      52          if  (typs(cstype csa(i)) > typ) cont do;  $ not eligable.
      53          if  (lc ^= lc_semicolon & lc ^= toks(cstype csa(i))) cont do;
      54
      55          $   we now have an entry whose first tokens match.  this is
      56          $   saved as best so far.
      57          csap1 = i;  $ save for later analysis.
      58
      59          $   now compare the rest of the tokens.
      60          if  (ntoks > toknum csa(i)) cont do;  $ too many tokens given.
      61          org = tokorg csa(i) - 1;   $ set to one below origin.
      62          do  j = 1 to toknum csa(i);  $ scan all tokens in original.
      63              if  (j > ntoks) quit do i;  $ found match.
      64              if  (stoks(j) ^= csatok(org+j)) cont do i;  $ no match.
      65              end do;
      66
      67          quit do i;  $ we have a match.
      68          end do;
      69
      70      csap = i;  $ set return value.
      71
      72      $   now, if no perfect match was found and a close match was found
      73      $   give an error message and use the close match.
      74      if  csap = 0 & csap1 ^= 0 then  $ use close match.
      75          ermesarg = csap1;  call ermes(43);  $ print error message.
      76          csap = csap1;  $ use close match.
      77          end if;
      78
      79      end subr findcsa;
       1 .=member  closer
       2      subr closer;   $ close last opened opener.
       3      $   this routine closes the last opened opener.  the action
       4      $   taken depends on the type of opener.
       5      size  csam(csasz);        $ -csa- entry being closed.
       6      size  arithop(ps);        $ arithmetic operation to issue.
       7      size  comop(ps);          $ comparison operation to issue.
       8      size  i(ps);              $ temporary.
       9      size  hap(ps);            $ pointer to -ha-.
      10
      11      csam = csa(csaptr);  $ extract entry to close.
      12      go to l(cstype csa(csaptr)) in 1 to cstypes;  $ select action.
      13
      14 /l(cstype_nameset)/
      15      $   for a nameset, just rest nameset to use.
      16      nstouse = oldmblk csam;  go to ret;
      17
      18 /l(cstype_while)/    /l(cstype_until)/
      19      $   for -while- and -until- generate go to body; /end/
      20      push(testlbl csam);  call gengol(op_goto);
      21      labdef(endlbl csam);  go to ret;
      22
      23 /l(cstype_if)/
      24      $   unless this is a -then-, define end label.
      25      if  csiftype csam ^= csiftype_then then
      26          labdef(endlbl csam);
      27          end if;
      28
      29      $   now unless this is an -else-, define the body label.
      30      if  csiftype csam ^= csiftype_else then
      31          if  trflowfg then  $ flow tracing.
      32              trflow(flowifnsf);  $ generate trace code.
      33          else    $   just define body label.
      34              labdef(bodylbl csam);
      35              end if;
      36          end if;
      37
      38      go to ret;  $ done.
      39
      40
      41 /l(cstype_do)/
      42      $   generate test label if referenced.
      43      if  testlbl csam then   labdef(testlbl csam);  end if;
      44
      45      $   now select the arithmetic and comparison operations
      46      $   depending on the sign of the increment.
      47      if  dosignp csam
      48          then    arithop = op_sub;  comop = op_ge;  $ sign was -.
      49          else    arithop = op_add;  comop = op_le;  end if;  $ sign +.
      50
      51      $   now generate the increment (decrement).
      52      push(dovarp csam) push(dovarp csam) push(doincp csam)
      53      call arith(arithop);  call genasin(1, 0);
      54
      55      $   now generate the test and branch to body label.
      56      push(dovarp csam);  push(dohip csam);  call arith(comop);
      57      push(bodylbl csam);  call genifgo(op_if);
      58
      59      $   now define the end label.
      60      labdef(endlbl csam);
      61
      62      $   finally, must rest the busy bits for any obtained -do- variabl
      63      hap = dohip csam;  $ start with high index.
      64      while  yes;  $ loop until quit.
      65          if  namintern ha(hap) then  $ this was internal.
      66              do  i = 1 to dovarptr;  $ find spot.
      67                  if  dovars(i) = hap then
      68                      .f. i, 1, dovarbusy = no;  $ show not busy.
      69                      quit do;  $ done with scan.
      70                      end if;
      71                  end do;
      72              end if;
      73
      74          $   now if this was increment, done.
      75          if  (hap = doincp csam) quit while;
      76
      77          hap = doincp csam;  $ else set to increment.
      78          end while;
      79
      80      go to ret;  $ done with this case.
      81
      82
      83 /l(cstype_subr)/   /l(cstype_fnct)/   /l(cstype_prog)/
      84      $   first, list last line if not already listed.
      85      if  (listsw) call lstlin; $ -lstlin- does nothing if listed.
      86
dsz    8      $   if function, check that function has been sized.
dsz    9      if  fswitch then  $ if function
dsz   10          if  syze voa(voafnct) = 0  then  $ if unsized
dsz   11              ermesarg = subinfo(1);  $ copy ha index.
dsz   12              call ermes(19);
dsz   13              end if;
dsz   14          end if;
dsz   15
      87      $   now check for undefined labels.
      88      terml(yes)    $ in case there are error messages.
      89      do  i = 1 to lablistptr;  $ scan all labels.
      90          if  (labvoa lablist(i)) cont do;  $ label is defined.
      91          if  (namintern ha(labha lablist(i))) cont do;  $ internal labe
      92          nerrors = nerrors+1;  $ increment error count.
mgfc  24 .+s10    error_s10;  $ give s10 error character.
      93          textl(error_notice) textl('expect label ''')
      94          naml(labha lablist(i)) textl(''' to be defined.') endl
      95          end do;
      96
      97      $   now compute and print error statistics.
      98      erthis = nerrors - erprev;  erprev = nerrors;
      99      warnthis = nwarnings - warnprev;  warnprev = nwarnings;
     100
     101      if  erthis ^= 0 ! warnthis ^= 0 then
     102          listl(listsw=no) endl listl(yes)  $ conditionally print a blan
     103          end if;
     104
     105      if  erthis then  $ print error count.
     106          textl('******* ') intl(erthis) textl(' errors detected in ''')
     107          textl(currsubrname) textl('''.') endl
     108          end if;
     109
     110      if  warnthis then  $ print number of warnings.
     111          textl('******* ') intl(warnthis) textl(' warnings in ''')
     112          textl(currsubrname) textl('''.') endl
     113          end if;
     114
     115      if  erthis ^= 0 ! warnthis ^= 0 then  endl endl end if;
     116      terml(no)   $ stop writing to terminal.
     117
     118      call genret;  $ generate return statement.
     119      call blkend;  $ end the basic block.
     120      call sortvars;  $ allocate local storage.
     121      call assembl;  $ write out a -voa- file.
     122      call purge;  $ clear tables for next time.
     123
     124 /ret/
     125      csatokptr = tokorg csam - 1;  $ reset pointer.
     126      csaptr = csaptr - 1;  $ pop -csa-.
     127
     128      end subr closer;
       1 .=member  arith
       2      subr arith(op);  $ generator for binary operations
       3      $   retrieve arguments from argstack.  if both are constants
       4      $   then try to perform operation at compile time.  if arguments
       5      $   same or one of them is the constant 0 or the constant 1, try
       6      $   to find a formal identity, as encoded in the table -fidtab-.
       7      $   check for mixed-mode arithmetic (reals and non-reals),as
       8      $   well as unexpected operations ,such as .or.) on reals.
       9      $   if a computation can be performed at compile time, see if
      10      $   negative result is acceptable.  if so, keep constant in sign
      11      $   and magnitude form, with -signbit- in -voa- noting negative
      12      $   sign.
      13      size  resat(ps);   $ ha index of result
      14      size  op(ps);  $ opcode as received
      15      size  opcd(ps);
      16      size  realops(ps);
      17      size  s1(ps), s2(ps);  $ sizes of inputs.
      18      size  v(ws);
      19      size  v1(ws);
      20      size  v2(ws);
      21      size  a1(ps), a2(ps);  $ ha indexex of inputs.
      22      size  ibsize(ps);       $ constant size in bits
      23      size  am1(ps), am2(ps); $ arithmetic modes of inputs
      24      size  fidc(ps);  $ case for formal identity search
      25
      26      $   formal identities are encoded in the table -fidtab-.
      27      $   the result is encoded as follows:
      28      $   0 - result is constant 0,
      29      $   1 - result is constant 1,
      30      $   2 - result is the non-constant input
      31      $   3 - result must be computed.
      32      $   at most one input is assumed to be constant 1 or 0, as case
      33      $   where both inputs constants handled by constant folding.
      34
      35      $   it is left as an exercise to the zealous implementor to extend
      36      $   search for formal identities to real numbers, and perhaps even
      37      $   standard functions.
      38
      39      size  fidtab(20);  dims fidtab(op_sne);
      40
      41      $.                        4. 3. 2. 1. 0.  (fidc value)
      42      $.  a1                    e  e  e  1  0
      43      $.  a2                    1  0  e  e  e
      44      data fidtab(op_add ) = 4b'3  2  3  3  2';  $ +
      45      data fidtab(op_sub ) = 4b'3  2  0  3  3';  $ -
      46      data fidtab(op_mul ) = 4b'2  0  3  2  0';  $ *
      47      data fidtab(op_div ) = 4b'2  3  1  3  0';  $ /
      48      data fidtab(op_and ) = 4b'3  0  2  3  0';  $ &
      49      data fidtab(op_or  ) = 4b'3  2  2  3  2';  $ !
      50      data fidtab(op_exor) = 4b'3  2  0  3  2';  $ .ex.
      51      data fidtab(op_eq  ) = 4b'3  3  1  3  3';  $ =
      52      data fidtab(op_ne  ) = 4b'3  3  0  3  3';  $ =
      53      data fidtab(op_gt  ) = 4b'3  3  0  3  3';  $ >
      54      data fidtab(op_ge  ) = 4b'3  3  1  3  3';  $ >=
      55      data fidtab(op_lt  ) = 4b'3  3  0  3  3';  $ <
      56      data fidtab(op_le  ) = 4b'3  3  1  3  3';  $ <=
      57      data fidtab(op_seq ) = 4b'3  3  1  3  3';  $ .seq.
      58      data fidtab(op_sne ) = 4b'3  3  0  3  3';  $ .sne.
      59
      60      dims realops (10);      $ map from integer into reals
      61      data realops = rop_add, rop_sub, rop_gt, rop_lt, rop_ge,
      62                     rop_le, rop_eq, rop_ne, rop_mul, rop_div;
      63      $   corresponds to real  +  -  gt  lt  ge  le  eq  ne  *  /
      64      opcd = op;
      65      pop(a2); pop(a1);  $ retrieve two arguments.
      66      $   main ordinary operator generator
      67      $   uses-emit 2 - routine for code emission
      68      call setq(a1);  call setq(a2);
      69      if  op = op_ccat then  $ see if .cc. on constants
      70          call ctcat(resat, a1, a2);
      71          if  (resat) go to ret;  $ if constant result, done
      72          go to normseq;
      73          end if;
      74      if  opcd = op_pad  then  $ do pad separately.
      75          call genpad(resat, a1, a2);
      76          go to ret;
      77          end if;
      78      if(op > op_sne) go to normseq;
      79      am1 = amode voa(ep ha(a1)); am2 = amode voa(ep ha(a2));  $ modes
      80      if  (am1 ! am2) go to real;
      81      if  (hascon ha(a1) & hascon ha(a2)) go to constfold;
dsr   17      $   do not attempt folding if either input multi-word.
dsr   18      if  (syze voa(ep ha(a1))>mws ! syze voa(ep ha(a2))>mws)
dsr   19          go to normseq;
      82      if  a1=ha_0 ! a1=ha_1 ! a2=ha_0 ! a2=ha_1 ! a1=a2 then
      83      $   may have formal identity.
      84          fidc = 2;  $  assume  e op e
      85          if  (a1=ha_0)  fidc = 0;
      86          if  (a1=ha_1)  fidc = 1;
      87          if  fidc = 2  then
      88              if  (a2=ha_0)  fidc = 3;
      89              if  (a2=ha_1)  fidc = 4;
      90              end if fidc = 2;
      91
      92          go to give (.f. fidc*4 + 1, 4, fidtab(op)) in 0 to 3;
      93          /give(0)/  resat = ha_0; go to ret;  $ result is constant 0
      94          /give(1)/  resat = ha_1; go to ret;  $ result is constant 1
      95          /give(2)/
      96               if  hascon ha(a1)
      97                   then  resat = a2;  $ if a1 constant, result is a2
      98                   else  resat = a1;  $ result is a1 (the non-constant)
      99                   end if;
     100                   go to ret;
     101          end if;
     102 / give(3) /
     103 /normseq/
     104      call emit2(opcd, a1, a2, resat);
     105 /ret/
     106      push(resat);
     107      return;
     108 /real/
     109      if  am1 ^= am2 then
     110          call ermes(44);
     111          resat = ha_1;
     112          go to ret;
     113          end if;
     114
     119 .+realsc     if  (hascon ha(a1) & hascon ha(a2))  go to realconstfold;
     120      opcd = realops(op);
     121      go to normseq;
     122/constfold/
     123      v1 = conval(a1);  v2 = conval(a2);
     124      s1=.fb. v1 ; s2=.fb.v2;
     125      go to l(op) in 1 to 15;
     126 / l(op_lt) /       v = v1 < v2;  go to con1;
     127 / l(op_le) /       v = v1 <=v2;  go to con1;
     128 / l(op_gt) /       v = v1 > v2;  go to con1;
     129 / l(op_ge) /       v = v1 >=v2;  go to con1;
     130 / l(op_eq) /       v = v1 = v2;  go to con1;
     131 / l(op_ne) /       v = v1 ^=v2;  go to con1;
     132 / l(op_add) /      v = v1 + v2;  go to signtest;
     133 / l(op_sub) /      v = v1 - v2;  go to signtest;
     134 / l(op_mul) /      ibsize = s1 + s2;
     135 .+s66    if ibsize>48 then go to normseq;   end if; /* 6600 hardware */
     136                    v = v1 * v2;  go to signtest;
     137 / l(op_div) /      if  (v2=0)  go to normseq;  $ aboid divide by 0
     138                    v = v1 / v2;  go to signtest;
     139 / l(op_and) /      v = v1 & v2;  ibsize = .fb. v; go to con;
     140 / l(op_or) /       v = v1 ! v2;  ibsize = .fb. v;  go to con;
     141 / l(op_exor) /     v = v1 .exor. v2;  ibsize = .fb. v; go to con;
     142 / l(op_seq) /
     143 / l(op_sne) /
     144      $   here for string comparisons; for now just do operation.
     145      go to normseq;
     146 /con1/   ibsize = 1;  go to con;
     147 /signtest/
     148      ibsize = .fb. v;
     149      if  v < 0  then
     150 .+ncfstat    ncftot = ncftot+1; $ count negative constants
     151          if  (ncfopt=no) go to normseq; $ if user no wants neg con fold
     152          signofcon = yes;  ibsize = mws;
     153          end if v;
     154
     155 /con/
     156      $   insert one word constant into ha
     157      cclt = dectok;
     158      ccsyze = ibsize + (ibsize=0);  ccval(1) = v; ccvalptr = 1;
     159      call inscon(resat);
     160      signofcon = 0;  $ reset sign flag to positive
     161      go to ret;
     162 .+realsc.
     163      real r, r1, r2;
     164 /realconstfold/
     165      r1 = val(vbeg voa(ep ha(a1)));  r2 = val(vbeg voa(ep ha(a2)));
     166      go to ro(op) in 1 to 15;
     167 / ro(op_lt) /      r = r1 <  r2; go to rcon1;
     168 / ro(op_le) /      r = r1 <= r2; go to rcon1;
     169 / ro(op_gt) /      r = r1 >  r2; go to rcon1;
     170 / ro(op_ge) /      r = r1 >= r2; go to rcon1;
     171 / ro(op_eq) /      r = r1 =  r2; go to rcon1;
     172 / ro(op_ne) /      r = r1 ^= r2; go to rcon1;
     173 / ro(op_add) /     r = r1 + r2;  go to rcon;
     174 / ro(op_sub) /     r = r1 - r2;  go to rcon;
     175 / ro(op_mul) /     r = r1 * r2;  go to rcon;
     176 / ro(op_div) /     if  (r2=0.0) go to normseq;
     177                    r = r1 / r2;  go to rcon;
rcfa   1 / ro(op_and) /
rcfa   2 / ro(op_or) /
rcfa   3 / ro(op_exor) /
rcfa   4      go to normseq;  $ don't bother to fold logical ops on reals.
     181 / ro(op_seq) /  / ro(op_sne) /  $ error if string comparison for reals.
     182      call ermes(12);
     183      go to normseq;
     184 /rcon/
     185      cclt = realtok;
     186      ccsyze = rlsz; ccval(1) = r; ccvalptr = 1;
     187      call inscon(resat);
     188      go to ret;
     189
     190 /rcon1/
     191      cclt = dectok;
     192      ccval(1) = v;  ccvalptr = 1;
     193      ccsyze = 1;  call inscon(resat);
     194      go to ret;
     195 ..realsc
     196      end subr arith;
       1 .=member  marith
       2      subr marith(op);  $ monadic operator processor
       3      size  a1(ps);   $ pointer to -ha- entry
       4      size  resat(ps);  $ result pointer
       5      size  op(ps);   $ operation code
       6      size  hap(ps);   $ temporary used for .sds.
       7      size  t(ws);   $ integer value
       8      size  s(ps);              $ size of .not. operand.
       9
      10      pop(a1);  call setq(a1);  $ get and check operand
      11      if  op = 1 then   $ special case for .len.
      12          if  const voa(ep ha(a1)) & lextype voa(ep ha(a1))=strtok then
      13              pushint(nchars ha(a1));  $ length is constant
      14          else
      15              $   generate .f. 1, .sl., a1
      16              push(ha_1); pushint(msl); push(a1); call genextr(op_fext);
      17              end if;
      18          return;
      19          end if;
      20
      21      $   if unary plus, just return input.
      22      if  (op=2)  then  push(a1);  return;  end if;
      23      if  op = op_usub then   $ unary minus
      24          if  amode voa(ep ha(a1)) then
      25 .+realsc.
      26              real r;
      27              if  hascon ha(a1) then  $ can fold
      28                  r = conval(a1); r = -r; $ get result
      29                  cclt = realtok; t = r; go to folded;
      30                  end if;
      31 ..realsc
      32              call emit1(rop_usub, a1, resat);
      33              go to ret;
      34          else
      35              push(ha_0); push(a1); call arith(op_sub);
      36              return;
      37              end if;
      38          end if;
      39
      40      $   now, check for constant values
      41      if  hascon ha(a1) then  $ safe constant
      42          t = conval(a1);  $ get constant value
      43          if  op = 0 then  $ .sds.
      44              t = ((t*mcs+msl+mso+mws-1)/mws)*mws;
      45              cclt = dectok;  $ set to decimal token
      46          elseif  op = op_not then  $ .not.
      47              s = .fb. t;  if (s=0)  s = 1;  $ find size.
      48              t = .f. 1, s, (.not. t); cclt = bittok;
      49          elseif  op = op_nb then   $ .nb.
      50              t = .nb. t; cclt = dectok;
      51          else    $ .fb.
      52              t = .fb. t; cclt = dectok;
      53              end if;
      54 /folded/
      55          ccsyze = .fb. t + (t=0); ccval(1) = t; ccvalptr = 1;
      56          call inscon(resat);  $ insert constant
      57          go to ret;
      58          end if;
      59
      60      $   else, emit operation
      61      if  op = 0 then   $ .sds.
      62          push(a1); pushint(mcs); call arith(op_mul);
      63          pushint(msl+mso+mws-1); call arith(op_add);
      64          pushint(mws);           call arith(op_div);
      65          pushint(mws);           call arith(op_mul);
      66      else
      67          call emit1(op, a1, resat);
      68 /ret/
      69          push(resat);  $ push result onto stack
      70          return;
      71          end if;
      72
      73      end subr marith;
      74
      75
       1 .=member  gendebug
       2      subr gendebug(case, value);  $ generator for -debug- statement
       3      size  case(ps);  $ parameter type
       4      size  value(1);  $ parameter setting
       5      size  a1(ps);    $ -ha- pointer
       6
       7      if  case = 0 then  $ initialization/termination
       8          if  value = 0 then   $ initialization
       9              dbgparm = 0; dbgchange = 0;  $ clear parameters
      10              dbgha = 0;   $ clear -ha- pointer
      11          else
dss   54              testdebug;
      15              if  dbgha then  $ must generate code to move
      16                  call advstr(lvgen, a1);  $ build variable
dss   55                  push(a1) pushint(mws); localforce = yes;
      18                  call gensiz;  $ size variable
      19                  push(a1) call gendat(2);  $ begin data statement
      20                  pushint(dbgparm); arglist(argptr) = 0; call gendat(4);
dss   56                  push(ha_1) pushint(mws-4) push(a1) push(dbgha)
dss   57                  call genasin(2, no);  $ generate .f. 1, (.ws.-4), dbgh
      23              else
      24                  pushint(dbgparm); pop(a1);  $ get first parameter set
      25                  end if;
      26              pushname(dbgha, debugnames(dbg_setx)); $ push name
      27              push(a1); pushint(dbgchange); arglist(argptr) = 1; $ push
      28              call gencall(call_parms);   $ call routine
      29              end if;
      30          return;
      31          end if;
      32
      33      if  case = 1 then  $ special case for line limit
      34          if  value then  $ value given
      35              pop(a1);  $ get it
      36              if  hascon ha(a1) then  $ if safe constant
      37                  if  .fb. conval(a1) > mps then
      38                      call ermes(16);  $ error
      39                      return;  $ ignore parm
      40                      end if;
dss   58                  .f. 1, mws-4, dbgparm = conval(a1);  $ set value
      42              else
      43                  dbgha = a1;  $ save for later
      44                  end if;
      45              end if;
dss   59          .f. 1, mws-4, dbgchange = yes;  $ set change flag
      47      else  $ simple case
dss   60          .f. (mws-5)+case, 1, dbgchange = yes;  $ set change flag
dss   61          .f. (mws-5)+case, 1, dbgparm   = value; $ set new value
      50          end if;
      51
      52      end subr gendebug;
      53
       1 .=member  genacc
       2      subr genacc;  $ process -access- declaration
       3      size  a1(ps);        $ ptr to ha
       4      size  j(ps);    $ do loop index
       5      size  n(ps);     $ number of accessed namesets
       6      size  nsi(ps);           $ nameset number
       7      size  xhap(ps);          $ xha index of nameset name
       8      size  i(ps);
       9
      10      $   generator routine called upon parsing an access statement to
      11      $   to access nameset
      12
      13      n = arglist(argptr) + 1;   $ number of names
      14      argptr = argptr - n;
      15      do  i =  0 to  n - 1;
      16          a1 = arglist(argptr + i);    $ ith name
      17          insglob(xhap, a1);
      18          nsi = xnsblk xha(xhap);  $ get nameset index in mba
      19          if  nsi  then $ if global variable name,
      20              .f. nsi, 1, accesstab = yes;  $ grant access, and note
      21              mbha mba(nsi) = a1;  $  record ha index.
      22          else
      23              ermesarg = a1; call ermes(17);
      24              end if;
      25          end do;
      26
      27      end subr genacc;
       1 .=member  genasin
       2      subr genasin(optyp, indxd); $ process assignment statement.
       3      $   generator for all assignment statements. the parameter indxd
       4      $   indicates whether the assignment is indexed. the parameter
       5      $   optype indicates the operation:
       6      $   1 - simple
       7      $   2 - .f. field
       8      $   3 - .e. field
       9      $   4 - .s. field
      10      $   5 - .ch. field
      11      $   6 - .len. field
      12      size  indxd(1);     $ flag indicating indexed store
      13      size  optype(ps);   $ operation type
      14      size  optyp(ps);  $ operation type as given.
      15      size  opc(ps); dims opc(12);
      16      data  opc = $ case to opcode map.
      17          op_asin, op_xasin, op_fasin, op_xfasin, op_easin,
      18          op_xeasin, op_sasin, op_xsasin, op_fasin, op_xfasin,
      19          op_fasin, op_xfasin;
      20      size  args(ps); dims args(12);
      21      data args = $ case to argument count map.
      22          2, 2+1, 4, 4+1,  4, 4+1,  4, 4+1,  3, 3+1,  2, 2+1;
      23      size  nargs(ps);    $ number of arguments of operation
      24      size  j(ps);        $ do loop index
      25      size  a1(ps), a2(ps), a3(ps), a4(ps); $ ha indices for args.
      26
      27      optype = optyp;
      28      nargs = args(2*optype - 1 + indxd); $ get no of args
      29      do  j = 1 to nargs;      $ verify operands
      30          call setq(arglist(argptr-j)); $ check input
      31          end do;
      32      $   if origin and length constant, see if .f. or .e.
      33      if  (optype=2)!(optype=3)  then $ if .e. or .f.,
      34          chasflg = no;  $ ensure flag is off.
      35          a1 = arglist(argptr - indxd - 4);  $ starting position.
      36          a2 = arglist(argptr - indxd - 3);  $ field length.
      37          if  hascon ha(a2)  then  $ if length constant,
      38              if  hascon ha(a1)  then $ and origin constant,
      39                  if  mod(conval(a1)-1, mws) + conval(a2) > mws then
      40                      if  (optype=2) optype = 3; $ must be .e.
      41                  else
      42                      if  (optype=3) optype=2; $ may be .f.
      43                      end if;
      44
      45                  if  mod(conval(a2), mcs) = 0 then  $ may be character
      46                      if  mod(conval(a1)-1, mcs) = 0 then  $ it is chara
      47                          chasflg = yes;  $ is character op
      48                          end if;
      49                      end if;
      50              else
      51                  if  ((optype=3)&(a2=ha_1)) optype=2;
      52              $  (convert .e.,...,1, to .f.,...,1, .)
      53                  end if;
      54              end if;
      55          end if;
      56
      57      if  indxd then  $ see if check index is in effect
      58          if  chinxf ha(arglist(argptr-3)) then  $ should check this sto
      59              call chinxr(arglist(argptr-3), arglist(argptr-2));
      60              end if;
      61          end if;
      62      go to l(optyp) in 1 to 6;  $ select code type
      63
      64 /l(5)/  $ .ch. - generate .f. (.f. .sl.+1, .so., a2)-cs*a1, cs, a2=a3
      65      $   for unindexed case and .f. sorg a2 - cs*a1,cs, a2(a3) = a4
      66      $   for indexed case.
      67      nargs = nargs + 1;    $ convert to .f. operation
      68      if  indxd  then  pop(a4);  end if;
      69      pop(a3);  pop(a2);  pop(a1); $ retrieve arguments.
      70      pushint((msl+1))   $ stack start of sds origin field for a2.
      71      pushint(mso)          $ field extract length
      72      push(a2)
      73      if  indxd  then     $ perform indexed load - sorg a2(i)
      74          push(a3);   call arith(op_xload);
      75          end if;
      76
      77      chasflg = (mod(msl, mcs) = 0 & mod(mso, mcs) = 0);
      78      call genextr(op_fext);     $ to do extract
      79      $   generate voa entry for a1 * cs
      80      pushint(mcs)
      81      push(a1)
      82      call arith(op_mul);
      83      call arith(op_sub);      $ do subtraction
      84      pushint(mcs)
      85      push(a2) push(a3)  $ target variable, index or source
      86      if  (indxd) then push(a4); call setq(a4); end if;
      87      chasflg = yes;  $ show character assigment
      88      go to l(1);   $ merge to normal code
      89
      90 /l(6)/  $ .len. - generate .f. 1, .sl., a1 = a2
      91      nargs = nargs+2;  $ convert to .f
      92      if  indxd then pop(a3); end if;
      93      pop(a2); pop(a1);  $ get arguments
      94      push(ha_1) pushint(msl) push(a1) push(a2)
      95      if  indxd then push(a3); end if;
      96      chasflg = (msl = mcs);  $ set if char. op.
      97      $   fall through to generation
      98
      99 /l(1)/    /l(2)/    /l(3)/    /l(4)/
     100      $   set global parameters for trace routine
     101      trstor1 = arglist(argptr - 1);
     102      trstor2 = arglist(argptr - 2);
     103      trstor3 = arglist(argptr - 3);
     104      trstor4 = arglist(argptr - 4);
     105      trstor5 = arglist(argptr - 5);
     106      trstors = a1;   $ for .ch. operation set to fbpos
     107      call emass(opc(2*optype - 1 + indxd), nargs);
     108      a1 = trstor2; if (indxd) a1 = trstor3; $ get target
     109      ermesarg = a1;  $ set for possible error message.
     110      if  argno voa(ep ha(a1)) ^= 0 & fswitch then  $ error
     111          call ermes(28);  $ cant change that var.
     112          end if;
     113
     114      if  dimn voa(ep ha(a1)) then  $ variable is dimensioned.
     115          if  (indxd = no) call ermes(49);  $ error.
     116      else  $ variable is not an array.
     117          if  (indxd) call ermes(40);  $ cannot use in this manner.
     118          end if;
     119      if  tracef ha(a1) & namintern ha(a1) = no then  $ trace
     120          trstorp = optype; trstori = indxd;  $ set parameters
     121          call trstorr(a1);  $ go trace store
     122          end if;
     123
     124      end subr genasin;
       1 .=member  gencall
       2      subr gencall(case);  $ subroutine or function call.
       3      $   this routine processes subroutine or function calls and
       4      $   indexed loads.  its main responsibility is to determine
       5      $   whether a subscript is a function call or indexed load.
       6      $   it also handles built-in functions.
       7      size  case(ps);         $ calling case.
       8      size  a1(ps);           $ routine or array name pointer.
       9      size  a2(ps);           $ argument to operation.
      10      size  resat(ps);        $ result of operation.
      11      size  n(ps);            $ number of arguments.
      12      size  argbase(ps);      $ base pointer to arguments on -arglist-
      13      size  glohc(ps);        $ hash index into -xha-.
      14      size  bifno(ps);        $ built-in function index.
      15      size  new(voasz);       $ new -voa- entry.
      16
      17      $   first, see if this is a subroutine call without parameters.
      18      if  case = call_noparms then  $ it is.
      19          pop(a1);  $ get routine name.
      20          n = 0;  argbase = argptr;  $ set no parameters.
      21          go to callcase;  $ merge with other subroutine call code.
      22          end if;
      23
      24      $   next get information about parameters.
      25      n = arglist(argptr) + 1;  $ get number of parameters.
      26      argbase = argptr - n - 1;  $ get pointer to below first parm.
      27      a1 = arglist(argbase);    $ get routine name.
      28      if  (case = call_parms) go to callcase;  $ if call, go process.
      29
      30      $   we now have either a function call or an indexed load.
      31      $   first, see if the name is in the -voa-.
      32      if  ep ha(a1) = 0 then  $ it is not in -voa-.
      33          $   next, check if it is a global.
      34          ifaglob(glohc, a1);  $ get global index.
      35          if  (glohc = 0) go to testbif;  $ is not a global.
      36          setqfok = yes;  call setq(a1);  $ page in name.
      37          end if;
      38
      39      $   now see if this is an array.
      40      if  dimn voa(ep ha(a1)) then  $ it is an array.
      41          $   if this is referenced with more than one subscript
      42          $   it is an error.
      43          if  n ^= 1 then  $ more than one subscript.
      44              ermesarg = a1;  call ermes(67);  $ output error message.
      45              argptr = argptr - n + 1;  $ reset pointer.
      46              end if;
      47
      48          $   now generate the indexed load.
      49          call arith(op_xload);  $ all arguments are in place.
      50          return;  $  done in this case.
      51          end if;
      52
      53      $   now, we have a subscripted reference to a variable which
      54      $   is not an array.  if it was never used as a simple variable,
      55      $   then it is a function.
      56      if  isavar voa(ep ha(a1)) then  $ was used as variable.
      57          ermesarg = a1;  call ermes(33);  $ print message.
      58          isavar voa(ep ha(a1)) = no;  $ now this is a function.
      59          end if;
      60
      61      $   otherwise, this is a normal user function.
      62      go to usefcn;
      63
      64
      65 /testbif/
      66      $   here the variable is not a global.  therefore, we must now
      67      $   check if it is a built-in function.
      68      bifxhasearch = yes;  ifaglob(bifno, a1);  bifxhasearch = no;
      69      if  (bifno = 0) go to usefcn;  $ if not, assume user function.
      70
      71      $   now see if the correct number of arguments were used.
      72      if  n ^= bfargs bifatrtab(bifno) then  $ error.
      73          ermesarg = a1;  call ermes(68);  $ print error message.
      74          argptr = argbase;  push(ha_1);  return;  $ ignore call.
      75          end if;
      76
      77      $   now see if this is an 'external' function.
      78      if  bfext bifatrtab(bifno) then  $ it is.
      79          $   now check for and process an alias to the function.
      80          if  bfalias bifatrtab(bifno) then  $ there is an alias.
      81              call xsdsnamr(bfalias bifatrtab(bifno));  $ get name.
      82              argptr = argbase;  pushname(a1, sdsnamstr);  $ put in -ha-
      83              end if;
      84
      85          $   now see if the function name is already in the -ha-.
      86          if  ep ha(a1) = 0 then  $ it is not in the -ha-.
      87              ep ha(a1) = voptr;  $ set pointer to -voa-.
      88              var ha(a1) = yes;  $ show real variable or constant.
      89              new = 0;  type new = quant;  naym new = a1;  $ build entry
      90              syze new = mws;  isafnct new = yes;  $ set size and status
      91              if  bfmode bifatrtab(bifno) then  $ is a floating function
      92                  if  targetmachine = m11 then  $ cannot support.
      93                      call ermes(69);  $ print error message.
      94                  else    $   set values.
      95                      syze new = rlsz;  amode new = yes;
      96                      end if;
      97                  end if;
      98
      99              voa(voptr) = new;  voaup;  $ update into -voa-.
     100              end if;
     101
     102          go to fnctmerge;  $ merge with normal function code.
     103          end if;
     104
     105      $   at this point we have a built-in function which is actually
     106      $   a special op-code.  we handle these depending on the number
     107      $   of operands.
     108      if  n = 2 then  $ this is binary function.
     109          argptr = argbase + 3;  $ point to correct place.
     110          pop(a2);  pop(a1);  $ get arguments.
     111          argptr = argptr-1;  $ step over name.
     112          call setq(a1);  call setq(a2);  $ ensure are sized.
     113          call emit2(opofbif(bifno), a1, a2, resat);  $ emit operation.
     114      else    $   function has one argument.
     115          argptr = argbase;  a1 = arglist(argptr+1);  $ get it.
     116          call setq(a1);  $ ensure is sized.
     117          call emit1(opofbif(bifno),a1,resat);  $ do operation.
     118          end if;
     119
     120      push(resat);  $ push result.
     121      return;  $ done.
     122
     123 /usefcn/   $ here to process user functions.
     124      $   first, see if it is in the -voa-.
     125      if  ep ha(a1) = 0 then  $ it isn't.
     126          if  ermflag & ntexterr = no then  $ output message.
     127              ermesarg = a1;  call ermes(19);
     128              end if;
     129
     130          $   now add entry to -voa-.
     131          ep ha(a1) = voptr;  var ha(a1) = yes;  $ set up -ha-.
     132          new = 0;  type new = quant;  naym new = a1;  $ set up -voa-.
     133          syze new = mws;  isafnct new = yes;  $ set more fields.
     134          voa(voptr) = new;  voaup;  $ insert into -voa-.
     135
     136      elseif  type voa(ep ha(a1)) ^= quant then  $ not a function.
     137          ermesarg = a1; call ermes(33);
     138
     139      else    $   valid.
     140          isafnct voa(ep ha(a1)) = yes;  $ dont allow as var.
     141          if  voanl voa(ep ha(a1)) then  $ this is a global.
     142              nlfnct nl(voanl voa(ep ha(a1))) = yes;  $ set global fnct.
     143              end if;
     144          end if;
     145
     146 /fnctmerge/  $   here to emit function call.
     147      call emcall(n, op_fcall, resat, argbase);  $ emit it.
     148      argptr = argbase;  push(resat);  $ push result.
     149      return;  $ done in this case.
     150
     151
     152 /callcase/   $   this is the case of a subroutine call.
     153      $   first, ensure name is in -voa-.
     154      if  ep ha(a1) = 0 then  $ not in yet.
     155          ep ha(a1) = voptr;  var ha(a1) = yes;  $ set up -ha-.
     156          new = 0;  naym new = a1;  $ build -voa- entry.
     157          voa(voptr) = new;  voaup;  $ insert into -voa-.
     158
     159      elseif  type voa(ep ha(a1)) then  $ not subroutine.
     160          ermesarg = a1; call ermes(34);  $ print error message.
     161          end if;
     162
     163      call emcall(n, op_call, resat, argbase);  $ emit the call.
     164
     165      argptr = argbase;  $ reset pointer to -arglist-.
     166
     167      end subr gencall;
       1 .=member  gencont
       2      subr gencont(csap); $ process -cont- statement
       3
       4      $   this routine generated code for the cont statement and
       5      $   is similar to genquit.  the cont do statement, however, is
       6      $   done separately as the test code for continuation of the
       7      $   loop is immediately generated. otherwise the code
       8      $   go to test label   is generated.
       9
      10      size  csap(ps);  $ parameter - -csa- pointer or zero
      11      size  csapp(ps);        $ ptr to csa array
      12      size  csam(csasz);     $ csa element
      13      size  arithop(ps);       $ arithetic operation
      14      size  comop(ps);         $ comparison operation
      15
      16 .+s66.
      17      if  csap then  $ special call from -genif- for -if (e) con t do-
      18          csam = csa(csap);  $ get -csa- entry of interest
      19          go to contdot;  $ process -cont do-
      20          end if;
      21 ..s66
      22      call findcsa(csapp, no);
      23      if  (csapp = 0) go to errmes;  $ error
      24      csam = csa(csapp);
      25 .+s66.
      26      if  (testlbl csam = 0) go to contdot;  $ this must be -do- for 660
      27 ..s66
      28      push(testlbl csam)  call gengol(op_goto);  $ go to testlabel
      29      return;
      30
      31 /errmes/  $ illegal cont statement
      32      call ermes(38);
      33      return;
      34 .+s66.
      35 /contdot/    $ do loop cont.
      36      $   generate code to increment(decrement) do loop var.
      37      $   if(cond) go to body label else go to endlabel
      38      if  dosignp csam  $  code depends on sign of by part.
      39          then  arithop = op_sub;  comop = op_ge;  $ by -.
      40          else  arithop = op_add;  comop = op_le;  $ by +.
      41      end if;
      42      $   increment or decrement do var
      43      push(dovarp csam)  push(dovarp csam)
      44      push(doincp csam)
      45      call arith(arithop);    call genasin(1,0); $ var = var+(-) inc
      46      $   perform comparison
      47      push(dovarp csam)   push(dohip csam)
      48      call arith(comop);
      49      $   if(cond) go to body label else go to endlabel
      50      push(bodylbl csam)     call genifgo(op_if);
      51      push(endlbl csam)  call gengol(op_goto);
      52 ..s66
      53
      54      end subr gencont;
       1 .=member  gendat
       2      subr gendat(case);  $ process -data- initialization
       3      $   generator for data statements is called in 4 possible cases -
       4      $   1 - data variable is indexed
       5      $   2 - simple data variable
       6      $   in both of above cases create new voa entry
       7      $   3 - replication of data value indicated. make one entry
       8      $   out of 2 entries ina rglist
       9      $   4 - end of data value list.  copy all data value pointers
      10      $   from arglist to xarg
      11
      12      size  n(ps);  $ number of data values
      13      size  a1(ps);             $ first argument in arglist
      14      size  a2(ps);            $ second argument in arglist
      15      size  case(ps);          $ case of call of routine
      16      size  new(voasz);        $ new voa item
      17      size  j(ps);             $ do loop index
      18      size  aptr(ps);  $ arglist index during copy to xarg
      19
      20      go to l(case) in 1 to 4;
      21 / l(1) /   / l(2) /
      22      replication = no; $ assume replcation will not occur.
      23      new = 0;   $ create new voa entry
      24      argbeg new = xargptr;   $ beginning of data values in xarg array
      25      opb new = yes;  $ flag as operation
      26      opcode new = op_data;
      27      if  case = 1 then
      28          pop(a2); pop(a1);  $ retrieve two arguments.
      29          call setq(a1);
      30          naym new = a1;
      31          inp3 new = ep ha(a2);
      32      else
      33          pop(a1);  $ non-indexed variabnle
      34          call setq(a1);
      35          naym new = a1;
      36          end if;
      37      $   verify that if data variable is nameset member, then nameset
      38      $   is being defined in the current routine.
      39      j = mblk voa(ep ha(a1));  $ machine block of variable
      40      if  mbxha mba(j) then  $ if nameset element
      41          if  mbdef mba(j) = no then
      42              ermesarg = a1; call ermes(2);
      43              end if;
      44          end if;
      45
      46      replication_origin = argptr;
      47      return;
      48
      49 / l(3) /
      50      if  replication=no  then  $ if first replication instance
      51          replication = yes;  $ note replication occurred.
      52          replicate = 0;    $ initialize replicate flag list
      53          end if;
      54
      55      a1 =  arglist(argptr-1);  $ replication value
      56      .f. argptr-2, 1, replicate = 1; $ note that this is replication va
      57      if  conval(a1) <= 0  then
      58          call ermes(6);   end if;
      59      return;
      60
      61 / l(4) /    $ copy data value ptrs to xarg array
      62      n =  arglist(argptr) + 1;
      63      aptr = replication_origin;
      64      if  (xargptr+n+1)>=xargmax  then $ if xarg would overflow,
      65          call ermes(8); return; end if;  $ issue error, and return.
      66      arglen new = n;  $ number of arguments in voa entry
      67      voa(voptr) = new;  voaup;   $ add new voa entry to voa
      68      do  j =  0 to  n - 1;
      69          xarg(xargptr + j) = 0;
      70          xarg_voa xarg(xargptr+j) = ep ha(arglist(aptr));
      71          $   now check to see if amode of variable and constant agree
      72          if  (amode  voa(ep ha(naym new)) ^=
      73              amode  voa(ep ha(arglist(aptr))))
      74              call ermes (45 );
      75
      76          if  replication  then  $ if replication occurred.
      77              if  .f. aptr, 1, replicate  then $ if next is repl. val.
      78                  aptr = aptr + 1;
      79                  xarg_rep xarg(xargptr+j) = ep ha(arglist(aptr));
      80                  end if;
      81              end if;
      82          aptr = aptr + 1;
      83          end do;
      84
      85      xargptr = xargptr + n;
      86      if  argptr^=aptr  then $ if not all values processed
      87          call ermey(7);
      88          end if;
      89
      90      argptr = replication_origin;
      91
      92      end subr gendat;
       1 .=member  gendim
       2      subr gendim;           $ generator for -dims- statement
       3      $   check that dimension is in range; if too large, truncate
       4      $   to maximum allowed value.  if dimension not constant,
       5      $   issue error message and return.
       6      $   verify that it is meaningful to assign dimension to item
       7      $   names; if not, report error and return.
       8      $   if item is global variable, save dimension information
       9      $   in global names list, nl.
      10
      11      size  dim(ps);
      12      size  i(ps),j(ps),k(ps);
      13      size  nln(ps);  $ name list index
      14      size  a1(ps), a2(ps);   $ ha ptrs
      15
      16      pop(a2); pop(a1);  $ retrieve two arguments.
      17
      18      if  (signbit voa(ep ha(a2))) call ermes(4);  $ negative.
      19
      20      if  conval(a2) > dimsmax then  $ dimension too larg
      21          call ermes(18);     $ so issue error message
      22          dim = dimsmax;        $ and truncate to maximum allowed
      23      else    $ if dimension in range
      24          dim = conval(a2);
      25          end if;
      26
      27      if  ep ha(a1) = 0 then
      28          ermesarg = a1; if  (ntexterr = no) call ermes(7);
      29          return;
      30          end if;
      31
      32      if  (type voa(ep ha(a1)) ^= quant) then  $ only quantities
      33          ermesarg = a1; call ermes(7);
      34          return;
      35          end if;
      36
      37      if  dim < 1 then  $ zero dimension not allowed
      38          call ermes(4);
      39          dim = 1; return;
      40          end if;
      41
      42      if  dimn voa(ep ha(a1)) then
      43 /dupdim/
      44          ermesarg = a1; call ermes(54);
      45          return; end if;
      46
      47      if  isafnct voa(ep ha(a1))  then $ attempt to dimension function
      48          ermesarg = a1; call ermes(55);  return;
      49          end if;
      50
      51      dimn voa(ep ha(a1)) = dim;        $ enter dimension value
      52      if  (arb voa(ep ha(a1))) return;  $ name is used as argument
      53      $   name is not argument, so is variable
      54      madr voa(ep ha(a1)) = madr voa(ep ha(a1))*dim;  $ set correct leng
      55      nln = voanl voa(ep ha(a1));  $ get -nl- index
      56      if  nln then  $ var. is global
      57          if  (nldimn nl(nln)) go to dupdim;
      58          nldimn nl(nln) = dim;  $ save dimension value
      59          end if;
      60
      61      end subr gendim;
       1 .=member  gendo
       2      subr gendo(case);  $ process -do- statement
       3      $   this routine implements the do loop opener
       4      $   the parameter case may be -
       5      $   1 - initialize - make new csa entry
       6      $   2 - do lloop with no by part. default value is 1
       7      $   3 - do loop with negative bypart
       8      $   4 - do loop with positive bypart
       9
      10      $   note that local variables are generated for the low do loop
      11      $   expression, the hi expression, and the increment expression.
      12      $   if any of these expressions are constant, no new variable need
      13      $   be generated.
      14
      15      size  case(ps);          $ type of call
      16      size  a1(ps);            $ ha pointer of do loop variable
      17      size  a2(ps);            $ ha ptr of low expr
      18      size  a3(ps);            $ ha ptr of hi expr
      19      size  a4(ps);            $ ha ptr of increment
      20      size  dolo(ps);          $ ha ptr of gneerated local variable
      21      size  dohi(ps);          $ generated local variable - hi quant
      22      size  doinc(ps);         $ generated local variabel - increment
      23      size  blab(ps);          $ ha ptr of body label
      24      size  elab(ps);          $ ha ptr of end label
      25      size  tlab(ps);          $ test label
      26      size  dosign(ps);        $ sign of do loop increment
      27      size  t(ps);             $ temporary.
      28      size  csam(csasz);     $ csa element
      29
      30      if  case=1  then
      31      $   initialize new csa entry
      32          csacountup('dostatement');     $ increment csaptr
      33          csam = 0;
      34          cstype csam = cstype_do;
      35          firstst csam = proclineno;
      36          tokorg csam = csatokptr + 1;
      37          csa(csaptr) = csam;
      38          return;
      39          end if;
      40
      41      $   determine sign of bypart.
      42      toknum csa(csaptr) = savetoks;
      43      savetoks = 5;    $ do not save any more tokens
      44      dosign = (case = 3);
      45      if  case = 2 then push(ha_1);  end if;  $ no by part.
      46      $   default is 1
      47      pop(a4); pop(a3); pop(a2); pop(a1);
      48          $ a1=var, a2 =lo, a3=hi, a4=inc
      49      call setq(a1);  $ get do loop variable
      50
      51      +*  getexpr(v, hap) = $hap is ha pointer. if item pointed to
      52      $   is a constant, nothing is done, else a local variable v is
      53      $   generated and hap assigned to it.
      54          v = hap;
      55          if  hascon ha(hap) = no  then
      56              call setq(hap);   $ make sure value is in -voa-.
      57              t = mps;  if  (syze voa(ep ha(hap)) > t) t = mws;  $ size
      58              call getdovar(v, t);  $ get variable for -do-
      59              push(v)  push(hap)
      60              call genasin(1,0); $ lv = hap
      61              end if;
      62          **
      63
      64      dolo = a2;   getexpr(dohi, a3)  getexpr(doinc, a4)
      65      push(a1)  push(dolo)    call genasin(1,0); $ dovar = dolo
      66      labget(elab)   $ generated end label
      67      if  dosign     $ determine comparison operator
      68          then  t = op_lt;    $ if 'by -.'
      69          else  t = op_gt;  end if;  $ if 'by +.'
      70      push(dolo)  push(dohi)  call arith(t);  $  compare ranges.
      71      push(elab)  call genifgo(op_if);  $ if...go to endlabel
      72
      73      $   define test label for all machines except s66
      74 .+s66    tlab = 0; if  targetmachine ^= m66 then  labget(tlab) end if;
      75 .-s66    labget(tlab);
      76
      77      $   define body label and update csa entry
      78      labget(blab)   labdef(blab)
      79      csam = csa(csaptr);
      80      bodylbl csam = blab;
      81      endlbl csam = elab;
      82      testlbl csam = tlab;
      83      dolop csam = dolo;
      84      dohip csam = dohi;
      85      doincp csam = doinc;
      86      dovarp csam = a1;
      87      dosignp csam = dosign;
      88      csa(csaptr) = csam;
      89      $   trace for debugging
      90      if  trflowfg then  trflow(flowdo) end if;
      91
      92      end subr gendo;
       1 .=member  genend
       2      subr genend;  $ generator for -end-.
       3      $   this routine processes an -end- statement.
       4      size  csap(ps);     $ -csa- pointer of entry matched.
       5      size  i(ps);        $ loop index.
       6
       7      $   first, see which opener is matched.
       8      call findcsa(csap, yes);   $ indicate not just loops.
       9
      10      $   check if an opener found.
      11      if  csap then  $ a matched opener was found.
      12          $   now check to see if this was the last opener.
      13          do  i = csaptr to csap+1 by -1;   $ process each unclosed entr
      14              ermesarg = i;  call ermes(60);  $ print error message.
      15              call closer;  $ close the opener.
      16              end do;
      17
      18          call closer;    $ close the opener.
      19
      20      else
      21          $   a matching opener was not found (even a close match).  so
      22          $   ignore the -end- statement.
      23          call ermes(61);  $ print error message.
      24          end if;
      25
      26      end subr genend;
       1 .=member  genextr
       2      subr genextr(opcarg);  $ generator for .f., .e., .ch., .s.
       3      $   generator for extract - .f., .e., .s., ann .ch. the value of
       4      $   opcase is the opcode
       5      $   for .ch. operator, in line code is generated. to compute the
       6      $   expression .ch. a1, a2 code for
       7      $       ((sorg a2) - cs * a1), cs, a2
       8      $   is generated. if either a1 or a2 are constant, this code
       9      $   can be simplified.
      10      size  opcase(6);    $ opcode
      11      size  resat(ps);    $ result
      12      size  a1(ps);       $ ha ptrs to operands
      13      size  a2(ps);
      14      size  a3(ps);
      15      size  conha1(ps);   $ ha constant ptrs
      16      size  conha2(ps);
      17      size  opcarg(ps);  $ code for extractor type
      18
      19      opcase = opcarg;
      20      if(opcase = 1) go to chext;  $ .ch. operation
      21      pop(a3); pop(a2); pop(a1);  $ retrieve three arguments.
      22      call setq(a1);  call setq(a2);  call setq(a3);
      23      chexflg = no;  $ show not character extraction.
      24      if  hascon ha(a2)  then  $ if length constant,
      25          $   if length is zero, return zero.
      26          if  a2 = ha_0  then  push(ha_0);  return;  end if;
      27          if  hascon ha(a1)  then $ and origin constant,
      28              if  mod(conval(a1)-1, mws) + conval(a2) > mws then
      29                  if  (opcase=op_fext) opcase = op_eext; $ must be .e.
      30              else
      31                  if  (opcase=op_eext) opcase=op_fext; $ may be .f.
      32                  end if;
      33
      34              if  mod(conval(a2), mcs) = 0 then  $ may be character.
      35                  if  mod(conval(a1)-1, mcs) = 0 then  $ is character.
      36                      chexflg = yes;  $ it is character extraction
      37                      end if;
      38                  end if;
      39          else
      40              if  ((opcase=op_eext)&(a2=ha_1)) opcase=op_fext;
      41          $  (convert .e.,...,1, to .f.,...,1, .)
      42              end if;
      43          end if;
      44
      45      call emit3(opcase, a1, a2, a3, resat);  $ to generate voa entry
      46      push(resat);
      47      return;
      48
      49 /chext/  $ generate inline code for the .ch. operation
      50      pop(a2); pop(a1);  $ retrieve two arguments.
      51      $   generate code for sorg a1
      52      call setq(a2);
      53      pushint((msl+1));  pop(conha1); $ get ha index of sorg value.
      54      pushint(mso);  pop(conha2);  $ get ha index of sorgl value.
      55      chexflg = (mod(msl, mcs) = 0 & mod(mso, mcs) = 0);
      56      call emit3(op_fext, conha1, conha2, a2, resat);
      57      push(resat)
      58      $   multiply first character a1  by  cs
      59      pushint(mcs)
      60      push(a1)
      61      call arith(op_mul);
      62      $   do subtraction
      63      call arith(op_sub);
      64      pushint(mcs);  pop(conha1); $ get ha index of mcs val.
      65      call setq(arglist(argptr-1)); call setq(a2);  $ check inputs.
      66      chexflg = yes;  $ show character operation
      67      call emit3(op_fext, arglist(argptr - 1), conha1, a2, resat);
      68      arglist(argptr - 1) = resat;
      69
      70      end subr genextr;
       1 .=member  gengoby
       2      subr gengoby;          $ -goby- generator
       3      $   check that number of labels given is not excessive.
       4      $   check that control item is value-producer.
       5      $   construct new voa entry with labels kept in xarg,
       6      $   noting label uses.
       7
       8      size  n(ps);
       9      size  i(ps);  $ loop index.
      10      size  new(voasz);  $ new voa entry build here if needed
      11      size  labn(ps);  $ label no
      12
      13      n = arglist(argptr)+1;
      14      argptr = argptr-n-1;
      15      call setq(arglist(argptr));
      16      new = 0;
      17      opb new = yes;
      18      opcode new = op_goby;
      19
      20      $   now all labels must be placed on xarg stack
      21      arglen new = n;
      22      argbeg new = xargptr;
      23      $   first check for room on stack
      24      if  (xargptr+n) > xargmax then  $ if -xarg- would overflow
      25          call ermes(8);  return;
      26          end if;
      27
      28      do  i = 1 to n;
      29          call setlabl(arglist(argptr+i), labn);
      30          xarg_voa xarg(xargptr + i - 1) = labn;
      31          end do i;
      32
      33      inp1 new = ep ha(arglist(argptr));
      34      inp3 new = proclineno;  $ record position in procedure.
      35      isuse(arglist(argptr));
      36      xargptr = xargptr + n;
      37      voa(voptr) = new;  voaup;
      38
      39      end subr gengoby;
       1 .=member  gengosl
       2      subr gengosl(c);  $ generator for subscripted labels
       3
       4      $   for subscripted label or goto, generate label name and then
       5      $   call -gengol-.  for switched goto, generate labels and call
       6      $   -gengoby-.
       7
       8      size  c(ps);  $ case
       9      size  slname(namsz);  $ generated label name
      10      size  sl(ps);         $ length of slname
      11      size  d(ps); dims d(3); $ digits of generated suffix code
      12      size  vlo(ws), vhi(ws);  $ values of label subscripts
      13      size  i(ps), l(ps);     $ do loop indices
      14      size  hap(ps);         $ ha index of generated name
      15      size  op(ps);     $ operation to be generated
      16      size  labvar(ps);        $ ha index of label array name
      17      size  lablo(ps), labhi(ps);  $ ha indices of subscripts
      18      size  lv(ps);   $ value of integer to be appended to name
      19      size  lw(ps);   $ number of columns sed by vale
      20      size  a1(ps), a2(ps), a3(ps), a4(ps); $ ha indices of arguments
      21
      22      go to l(c) in 1 to 4;
      23 / l(1) /   $  /l(c)/
      24      op = op_lab;  go to l(4);
      25 / l(2) /    $  'go to l(c)'
      26      op = op_goto; go to l(4);
      27 / l(4) /   $ common code for /l(c)/ and 'go to l(c);'
      28      pop(a2); pop(a1);  $ retrieve two arguments.
      29      labvar = a1; lablo = a2; labhi = a2;
      30 /def/
      31      $   generate labels, call appropriate generators.
      32      vlo = val(vbeg voa(ep ha(lablo)));
      33      vhi = val(vbeg voa(ep ha(labhi)));
      34
      35      if  (signbit voa(ep ha(lablo))) ! (signbit voa(ep ha(labhi))) !
      36          (vlo > 999) ! (vhi > 999) then call ermes(48); return; end if;
      37
      38      if  vlo>vhi  then  call ermes(47); return; end if;
      39
      40      $   see if putting these labels on -argstack- would overflow it.
      41      if  argptr + vhi - vlo > argmax - 15 then  $ overflow.
      42          call ermes(65);   call genexit;  $ fatal error.
      43          end if;
      44
      45      do  i = vlo to vhi;
      46          sdsname(slname, labvar); $ get label array name as sds
      47      $   last three digits of generated label taken from
      48      $   subscript value.
      49          lv = i;
      50          d(1) = lv/100; d(2) = mod(lv, 100)/10;
      51          d(3) = mod(lv, 10);
      52          lw = 1 + (lv>9) + (lv>99);  $ num chars in value
      53          slen slname = slen slname + 2 + lw;
      54          sl = slen slname;
      55          .ch. sl, slname = 1r); .ch. sl-lw-1, slname = 1r(;
      56          do  l = 1 to lw;
      57              .ch. sl-l, slname = charofdig(d(4-l));
      58              end do;
      59          pushname(hap, slname);
      60          if  (c=4) return;
      61          if  op  then  $ if not switch case
      62              call gengol(op);
      63              end if;
      64          end do;
      65
      66      if  op=0  then  $ if switch case, call gengoby
      67          arglist(argptr) = vhi - vlo; $ gengoby expects lab_count-1
      68          call gengoby;
      69          end if;
      70      return;
      71
      72 / l(3) /    $  'go to l(e) in e1 to e2'
      73      pop(a4); pop(a3); pop(a2); pop(a1); call setq(a2);  $ e must be qu
      74      $   generate code for goby starting at 1
      75      $   goby expression is e-(lo-1), compute it
      76          push(a2); $ e
      77          push(a3); push(ha_1); call arith(op_sub);  $ lo-1
      78          call arith(op_sub); $ e - (lo-1)
      79      labvar = a1; lablo = a3; labhi = a4;
      80      op = 0; go to def;
      81      end subr gengosl;
       1 .=member  gengol
       2      subr gengol(op);       $ -go- and -/lab/- generator
       3      $   single argument a1 is label. note label usage/definition
       4      $   according as operation is goto/labeldef.
       5      $   construct new voa etnntry, calling blkend if this is a
       6      $   label definition, which terminates basic block.
       7
       8      size  a1(ps);    $ ptr to ha
       9      size  op(ps);
      10      size  labn(ps);
      11      size  new(voasz);  $ new voa entry built here.
      12      pop(a1);
      13      $   go statement generator routine,combined with
      14      $   label routine. both include code emission routine.
      15      call setlabl(a1, labn);
      16      new = 0;
      17      opb new = yes;
      18      opcode new = op;
      19      naym new = a1;           $ index to ha
      20      inp1 new = labn;           $ index to lablist
      21      voa(voptr)=new;  voaup;
      22      if  op=op_lab  then
      23          call blkend;  $ label ends basic block.
      24          labldef(voptr, labn);
      25              if  trflowfg & namintern ha(a1) = no then  $ trace flow
      26                  trflowl = a1; trflow(flowlab);  $ trace label
      27              end if;
      28          end if;
      29
      30      end subr gengol;
       1 .=member  genifgo
       2      subr genifgo(ifcode);  $ process conditional branch
       3
       4      size  ifcode(ps);
       5      size  labn(ps);
       6      size  a1(ps), a2(ps);   $ ha ptrs
       7      size  new(voasz);  $ new voa entry built here.
       8      $   genif calls setq to verify that its first input is a quantity,
       9      $   and call setlab to verify that the second argument is a label
      10      $   a new voa operation entry is then constructued.
      11
      12      pop(a2); pop(a1);  $ retrieve two arguments.
      13
      14      $   if input to if is a constant we can evaluate, then we
      15      $   replace if by either goto or noop.
      16
      17      if  hascon ha(a1)  then
      18 .+ifconstat  ifcontot = ifcontot+1;
      19          if  (conval(a1) ^= 0) = (ifcode = op_if) then
      20              push(a2); call gengol(op_goto);  $ issue goto
      21 .+ifconstat  ifcongotos = ifcongotos+1;
      22              end if;
      23          return;
      24          end if;
      25
      26      call setlabl(a2, labn);
      27      call setq(a1);
      28      if  syze voa(ep ha(a1)) > mws then
      29          push(a1)  push(ha_0)
      30          call arith(op_ne);    pop(a1);
      31          end if;
      32      isuse(a1);
      33      new = 0;
      34      opb new = yes;
      35      opcode new = ifcode;
      36      inp1 new = ep ha(a1);
      37      inp2 new = labn;          $ index to label list
      38      naym new = a2;          $ index to ha
      39      voa(voptr)=new;  voaup;
      40
      41      end subr genifgo;
       1 .=member  genif
       2      subr genif(case);  $ process -if- statement
       3
       4      $   process various clauses of if statement, according to
       5      $   argument case.  meaning of each case given in code below.
       6
       7      size  case(ps);          $ type of call
       8      size  csanew(csasz);   $ new csa entry
       9      size  blab(ps);          $ body label ha ptr
      10      size  elab(ps);          $ end label ha ptr
      11      size  csapp(ps);  $ -csa- pointer
      12      size  t(ps);   $ temporary.
      13
      14      go to l(case) in 1 to 11;
      15 / l(1) /    $ make new entry in csa array.
      16      csanew = 0;
      17      csacountup(' if statement');
      18      cstype csanew = cstype_if;
      19      firstst csanew = proclineno;    $ line number in subr
      20      tokorg csanew =csatokptr + 1;
      21      csa(csaptr) = csanew;
      22      return;
      23 / l(2) /  $ then part.
      24      toknum csa(csaptr) = savetoks;   $ number of tokens in csatok
      25      savetoks = 5;    $ to indicate  not to save any more tokens
      26      labget(blab)    $ gnerate body label
      27      push(blab)  call genifgo(op_ifnot);   $ ifnot..go to blab
      28      bodylbl csa(csaptr) = blab;
      29      csiftype csa(csaptr) = csiftype_then;
      30      $   trace for debugging
      31      if  trflowfg then  trflow(flowift) end if;
      32      return;
      33 / l(3) /  $ process simple if statement, issue 'ifnot(a1) go to..'
      34      labget(elab)   $ generate an end label
      35      push(elab)  call genifgo(op_ifnot);  $ simple statement after
      36      $   condition - ifnot...go to endlabel
      37      endlbl csa(csaptr) = elab;
      38      csiftype csa(csaptr) = csiftype_sif;
      39      $   trace for debugging
      40      if  trflowfg then  trflow(flowift) end if;
      41      return;
      42 / l(4) /   $ end of simple staement - define end label
      43      elab = endlbl csa(csaptr);
      44      if  trflowfg then
      45      $   trace for debugging
      46          trflow(flowifsf) else labdef(elab) end if;
      47      savetoks = 5;   $ do not save tokens
      48      csatokptr = tokorg csa(csaptr) - 1;      $ reset ptr to csatok
      49      csaptr = csaptr - 1;   $ pop coas stack
      50      return;
      51 / l(5) /    $ else part
      52      if  csiftype csa(csaptr) = csiftype_elseif then
      53          elab = endlbl csa(csaptr);
      54      elseif  csiftype csa(csaptr) = csiftype_else then
      55          call ermes(62);  return;  $ this is an error.
      56      else
      57          labget(elab);   $ get an end label.
      58          end if;
      59
      60      push(elab);  call gengol(op_goto);  $ go to end label.
      61      blab = bodylbl csa(csaptr);
      62      if  blab = 0 then call ermes(41);   return;  end if;
      63      labdef(blab)   $ define bodylabel
      64      csiftype csa(csaptr) = csiftype_else;
      65      endlbl csa(csaptr) = elab;
      66      if  trflowfg then
      67      $   trace for debugging
      68          trflow(flowiff) end if;
      69      return;
      70 / l(6) /    $ if(cond) go to ...    this statement form is
      71      $   special cased from the simple statement after an if to produce
      72      $   better code. one conditional branch only need be gnerated
      73      $   instead of a conditional and unconditional branch.
      74      savetoks = 5;   $ do not save any more tokens
      75      csatokptr = tokorg csa(csaptr) - 1;   $ reset ptr to csatok
      76      csaptr = csaptr - 1;
      77      if  trflowfg then
      78          trflow(flowifgt)     $ true part for debugging
      79          else call genifgo(op_if);
      80          end if;
      81      $   trace for debugging
      82      if  trflowfg then  trflow(flowiff) end if;
      83      return;
      84 / l(7) /   $ after 'elseif' in elseif clause
      85      $   define body label for previous 'then' or 'elseif', then get
      86      $   new body label, generate 'ifnot (e) to to blab'.
      87      if  csiftype csa(csaptr) = csiftype_then then
      88      $   if previous clause is then, generate end label, branch to
      89      $   elab, define blab, get new blab, generate
      90      $   'ifnot(e) go to blab;' and set type to elseif type
      91          labget(elab); endlbl csa(csaptr) = elab; $ generate end label
      92          csiftype csa(csaptr) = csiftype_elseif;
      93      elseif  csiftype csa(csaptr) = csiftype_elseif then
      94          elab = endlbl csa(csaptr);
      95      else
      96          call ermes(50); return; $ must have 'then' or 'elseif' before
      97          end if;
      98
      99      push(elab); call gengol(op_goto); $ terminate then clause
     100      blab = bodylbl csa(csaptr);
     101      if  blab=0  then call ermes(41); return; end if;
     102      labdef(blab);
     103      labget(blab); bodylbl csa(csaptr) = blab;
     104      if  trflowfg then  trflow(flowiff)  end if;
     105      return;
     106 / l(8) /  $ after 'then' in elseif clause emit conditional branch
     107      blab = bodylbl csa(csaptr);
     108      if  blab=0  then  call ermes(41); return; end if;
     109      push(blab); call genifgo(op_ifnot);
     110      if  trflowfg then trflow(flowift) end if;
     111      return;
     112 / l(9) /  $ if (e) go to l(c)
     113      $   action similar to case=6, but use gengosl to process
     114      $   subscripted label in go to.
     115      call gengosl(4);
     116      go to l(6);  $ now have single label, treat as case=6
     117 / l(10) /   / l(11) /  $ if (e) quit/cont
     118      $   special cased by branching to test label for -cont- and
     119      $   end label for -quit- except in the case of a -cont do-
     120      $   for s66.
     121      call findcsa(csapp, no);  $ find which loop
     122      if  csapp = 0 then  $ error
     123          call ermes(case+27);  $ print error message
     124          go to l(4); $ attempt to recover
     125          end if;
     126      if  case = 10 then  $ quit
     127          elab = endlbl csa(csapp); $ get end label
     128      else  $ cont
     129          elab = testlbl csa(csapp); $ get test label
     130          end if;
     131 .+s66. $ check for -cont do-
     132      if  elab = 0 then  $ have it
     133          labget(elab) push(elab) call genifgo(op_ifnot); $ do if
     134          endlbl csa(csaptr) = elab; csiftype csa(csaptr) =csiftype_sif;
     135          if  trflowfg then  trflow(flowift) end if;
     136          call gencont(csapp); $ generate -cont do-
     137          go to l(4);  $ now end simple statement
     138          end if;
     139 ..s66
     140      push(elab) go to l(6);  $ treat as -if (e) go to-
     141
     142      end subr genif;
       1 .=member  genns
       2      subr genns;  $ process -nameset- declaration
       3      size  xhap(ps);         $ xha index of nameset name
       4      size  i(ps);    $ do loop index
       5      size  a1(ps);            $ ptr to entry in ha of nameset name
       6      size  csanew(csasz);     $ new -csa- entry.
       7
       8      $   begin nameset definition,  see if previous use as nameset.
       9      $   if so, return nameset index. otherwise build new nameset entry
      10      $   when nameset index obtained, set nstouse to indicate nameset
      11      pop(a1);
      12      nsflg = yes;    $ to indicate processing naemset
      13      insglob(xhap, a1);  $ add nameset name to xha
      14      i = xnsblk xha(xhap);  $ get nameset number (index in mba)
      15
      16      if  i=0  then  $ if new nameset, we must enter it in mba
      17          countup(mbaptr, nblocks, 'nameset');
      18          mba(mbaptr) = 0;
      19          mbxha mba(mbaptr) = xhap;  $ record xha position of name
      20          mbdef mba(mbaptr) = yes;  $ nameset defined in this routine
      21          xnsblk xha(xhap) = mbaptr;  $ record nameset index in mba
      22          i = mbaptr;
      23          end if;
      24
      25      mbha mba(i) = a1;  $ set -ha- index.
      26      $   is set
      27
      28      csanew = 0;  $ clear new -csa- entry.
      29      cstype csanew = cstype_nameset;  $ set opener type.
      30      oldmblk csanew = nstouse;  $ set old block.
      31      firstst csanew = proclineno;  $ set line number.
      32      tokorg csanew = csatokptr + 1;  $ set token list origin.
      33      toknum csanew = 1;   $ just nameset name.
      34      csatokptr = csatokptr + 1;  $ get space for token.
      35      csatok(csatokptr) = names(nayme ha(a1));  $ get token word.
      36      csacountup('nameset');  csa(csaptr) = csanew;  $ add new entry.
      37      savetoks = 5;  $ do not collect tokens.
      38
      39      nstouse = i;  $ set nameset to new one
      40      .f. i, 1, accesstab = yes;  $ grant access to nameset
      41
      42      end subr genns;
       1 .=member  genpad
       2      subr genpad(res, a1, a2);  $ generator for .pad.
       3      $   a1 .pad. a2  pads character string constant a1 with blanks
       4      $   to have length a2.  a2 must be integer constant.
       5      $   if arguments not valid or a2 too large, return a1; otherwise,
       6      $   build new constant and hash it in.
       7      size  res(ps);   $ result ha index.
       8      size  a1(ps), a2(ps);   $ working copies of a1, a2.
       9      size  l1(ps), l2(ps);   $ lengths of inputs.
      10      size  i(ps);            $ loop index.
      11
      12      res = a1;  $ set result to a1 in case error.
      13      if  (const voa(ep ha(a1)) = no)  go to err;
      14      if  (lextype voa(ep ha(a1)) ^= strtok)  go to err;
      15      if  (const voa(ep ha(a2)) = no)  go to err;
      16      l1 = nchars ha(a1);     $ length of string.
      17      if  (hascon ha(a2) = no)  go to err;
      18      l2 = conval(a2);        $ desired pad length.
      19      if  (l1>l2)  l1 = l2;  $ truncate if pad count longer than string.
      20      if  (l2 > toklenmax)  go to err;  $ if pad length too long.
      21      ccaptr = 0;
      22      $   get first string, copy into cca.
      23      if  l1  then
      24          do  i = 1 to (l1-1)/cpw + 1;
      25              .f. nameorg - i*ws, ws, sdsnamstr =
      26                  val(vbeg voa(ep ha(a1)) + i - 1);
      27              end do;
      28          slen sdsnamstr = l1;
      29          do  i = 1 to l1;
      30              ccaptr = ccaptr + 1;  cca(ccaptr) = .ch. i, sdsnamstr;
      31              end do;
      32          end if;
      33
      34      do  i = l1+1 to l2;  $ pad with blanks.
      35          ccaptr = ccaptr + 1;  cca(ccaptr) = 1r ;
      36          end do;
      37
      38      cclt = strtok;  call cnvcon;
      39      call inscon(res);
      40      return;
      41 /err/    $ if error, issue message and return a1.
      42      call ermes(53);  res = a1;
      43
      44      end subr genpad;
       1 .=member  genquit
       2      subr genquit;  $ process -quit- statement
       3
       4      $   genquit generates code for the quit statement.
       5      $   quit and cont statements refer to the innermost while, until,
       6      $   or do loop in which it occurs.  therefore, when a cont or
       7      $   quit statement appers within if-then-else statements the
       8      $   csa stack must be searched for the innermost loop.  the code
       9      $   generated is simply    'go to end label'   .
      10
      11      size  csapp(ps);          $ -csa- stack pointer.
      12
      13      call findcsa(csapp, no);  $ find loop
      14      if  (csapp = 0) go to errmes;
      15      if  (endlbl csa(csapp) = 0) go to errmes;
      16      push(endlbl csa(csapp))   call gengol(op_goto);   $ go to end labe
      17      return;
      18
      19 /errmes/  $ issue error message - illegal quit statement
      20      call ermes(37);
      21
      22      end subr genquit;
       1 .=member  genreal
       2      subr genreal;  $ process -real- declaration
       3      $   genreal is the generator routine invoked when processing
       4      $   a real declaration in a little program.  it sizes the
       5      $   variable to word-size and sets the amode field of
       6      $   the voa entry associated with the variable to amode_real.
       7
       8      pushint(rlsz);  $ size of real.
       9      if  targetmachine = m11 then   $ does not support reals yet.
      10          call ermes(69);  $ print error message.
      11      else  $ ok to build real.
      12          buildreal = yes;    $ set flag to tell gensiz to build real
      13          end if;
      14
      15      $   real quantity
      16      call gensiz;
      17      buildreal = no;    $ reset flag
      18
      19      end subr genreal;
       1 .=member  genret
       2      subr genret;           $ -return- generator
       3      size  new(voasz);  $ new voa entry built here.
       4      size  hap(ps);   $ dummy -ha- pointer
       5      $   genret buils voa entry for return operation
       6
       7      $   trace for debugging aids
       8      if  trentrfg then  trentry(entrend) end if;
       9      if  trflowfg then  trflow(flowend) end if;
      10      if  debuglevel = 2 then  $ must show exit from routine
      11          pushname(hap, debugnames(dbg_subx));  $ push routine name
      12          endblock = no;
      13          call gencall(call_noparms);  $ call routine
      14          end if;
      15
      16      $   for main program, issue call ltlfin(0,0).
      17      if  mainprogram  then
      18          pushname(hap, proc_terminate);
      19          push(ha_0);  push(ha_0);
      20          arglist(argptr) = 1;  $ two params.
      21          call gencall(call_parms);
      22          return;
      23          end if;
      24      new = 0;
      25      opb new = yes;
      26      opcode new = op_return ;
      27      voa(voptr)=new;  voaup;
      28
      29      end subr genret;
       1 .=member  gensiz
       2      subr gensiz;  $ -size- generator
       3      $   check that size value in range; if too big, truncate to
       4      $   allowed maximum size szmax.  check that item named can
       5      $   can be sized and has not been sized already.
       6      $   if sizing global variable, save information in xha,nl.
       7
       8      size  new(voasz);        $ used to build new voa entry
       9      size  sz(ps);  $ size value
      10      size  i(ps);             $ do loop index
      11      size  nssave(ps);  $ saves nameset index when localblock forced
      12      size  nlwd(nlsz);  $ nl entry to set
      13      size  a1(ps);
      14      size  a2(ps);  $ ha ptr
      15
      16      pop(a2); pop(a1);  $ retrieve two arguments.
      17      sz = val(vbeg voa(ep ha(a2)));
      18      if  sz > szmax  then  $ if size too big.
      19          call ermes(32);
      20          sz = szmax;
      21      elseif  sz < 1  then  $ if zero, report error and give size mws.
      22          call ermes(4);
      23          sz = mws;
      24          end if;
      25
      26      $   set trace and check flags
      27      tracef ha(a1) = trstorfg;  $ set trace flag
      28      chinxf ha(a1) = chinxfg;   $ set check flag
      29      $   now check special 'check' and 'trace' list
      30      do  i = 1 to dbgcspcp;  $ check 'check' stack
      31          if  dbgcspc(i) = a1 then  $ found
      32              dbgcspc(i) = 0;  $ clear place
      33              chinxf ha(a1) = .f. i, 1, dbgcspcf; $ get special value
      34              end if;
      35          end do;
      36
      37      do  i = 1 to dbgtspcp;  $ check 'trace' stack
      38          if  dbgtspc(i) = a1 then  $ found
      39              dbgtspc(i) = 0;  $ clear place
      40              tracef ha(a1) = .f. i, 1, dbgtspcf;  $ get special value
      41              end if;
      42          end do;
      43
      44      if  (ep ha(a1) = 0)  go to sizenew;  $ sizing.
      45      if  arb voa(ep ha(a1))  then   $ sizing argument
      46          if  syze voa(ep ha(a1)) then
      47              ermesarg = a1; call ermes(56);
      48              end if;
      49
      50          syze voa(ep ha(a1)) = sz;  type voa(ep ha(a1)) = quant;
      51          if  (buildreal) amode voa(ep ha(a1)) = amode_real;
meal  21          if  trentrfg & trentrargs then  $ call to print argument
      53              trentry(2+a1);  $ bias of 2 for ha pointer
      54              end if;
      55          return;
      56          end if;
      57
      58      $   not argument name, see if sizing function begin defined
      59      if  fswitch & a1 = subinfo(1) then
      60          if  syze voa(voafnct) then  $ re-sizing.
      61              ermesarg = a1;  call ermes(56);
      62              end if;
      63
      64          syze voa(voafnct) = sz;
      65          if  (buildreal) amode voa(voafnct) = amode_real;
      66          subinfo(3) = voafnct;  $ voafnct is loc at which def begins
      67          return;
      68          end if;
      69
      70      $   see if this item is already sized.
      71      if  syze voa(ep ha(a1)) then  $ already has size assigned.
      72          ermesarg = a1; call ermes(56);
      73          end if;
      74
      75      $   if we get here, something strange is happening, but size the
      76      $   item anyway to prevent further errors.
      77      syze voa(ep ha(a1)) = sz;  $ set size of item.
      78      if  (buildreal)  amode voa(ep ha(a1)) = yes;  $ set if real.
      79      return;
      80
      81 /sizenew/
      82      new = 0;    $ build new voa entry
      83      ep ha(a1) = voptr;
      84      var ha(a1) = yes;         $ is variable
      85      if  (buildreal) amode new = amode_real;
      86      if  localforce then  $ save current nameset index, force local
      87          nssave = nstouse;  nstouse = localblock;  end if;
      88
      89      vbeg new = mbchain mba(nstouse);  $ set chain to last
      90      mbchain mba(nstouse) = voptr;  $ this is head of list
      91      mblk new = nstouse;  $ enter current machine block
      92      mbdef mba(nstouse) = yes;
      93      mbused mba(nstouse) = yes; $ use of this nameset.
      94      madr new = (sz-1)/mws + 1;  $ set size in words
      95      type new = quant; syze new = sz;  naym new = a1;
      96      voa(voptr) = new; voaup;  $ add at top of voa
      97      $   if localforce has been set, we must use local block
      98      if  localforce then
      99          nstouse = nssave;  $ restore priod nameset
     100          localforce = no;  return; end if;
     101      if  nstouse = localblock then return; end if;
     102      $   done if local variable, if
     103      $   global names array, so can be used by following routines
     104      insglob(i, a1);
     105      if  nlno xha(i) then  $ is global, resizing
     106          ermesarg = a1; call ermes(56);
     107          return;
     108          end if;
     109
     110      $   add new global variable
     111      countup(nlptr, nlmax, 'nl');
     112      nlwd = 0;
     113      nlsize nlwd = sz;  $ save size
     114      if  (buildreal) nlamode nlwd = amode_real;
     115      nlblk nlwd = nstouse;   $ save machine block
     116      nlha nlwd = i;
     117      nltrac nlwd = tracef ha(a1);  $ set global trace
     118      nlchinx nlwd = chinxf ha(a1);  $ set global check
     119      nl(nlptr) = nlwd;
     120      nlno xha(i) = nlptr;
     121      voanl voa(ep ha(a1)) = nlptr;  $ link voa to -nl-
     122
     123      end subr gensiz;
       1 .=member  gensub
       2      subr gensub(casearg);  $ fnct / prog / subr generator.
       3      size  casearg(ps);      $ case.
       4      size  case(ps);  $ call case
       5      size  i(ps);  $ loop index.
       6      size  j(ps);
       7      size  new(voasz);        $ used to build new voa entry
       8      size  a1(ps);  $ ha ptr
       9      size  xhap(ps);         $ xha index of nameset name
      10      size  temptitle(.sds. (cpw+ cpw*wpc)); $ used to build  subtitle
ldse  18      size  ta(ws);  dims ta(8);  $ current time array.
      11
      12      $   subroutine generator for declaration
      13      $   together with function declaration generator
      14      $   if an end card does not preceed the present statement, call
      15      $   genend, thus effectively inserting an end card.-
      16      case = casearg;
      17      go to c(case) in 0 to 5;  $ select case.
      18
      19 /c(no)/   /c(yes)/   $ subr/fnct encountered
      20     /c(5)/
      21      do  j = csaptr to 1 by -1;  $ end any open blocks.
      22          ermesarg = j; call ermes(60);  $ print error message.
      23          call closer;  $ close the block.
      24          end do;
      25
      26      if  voptr  ^= voafnct then
      27          call ermes(57);  $ print error message.
      28          call purge;
      29          end if;
      30
      31      ntexterr = no;  $ clear error flag
      32      csaptr = 1;
      33      fswitch = (case = 1);
      34      mainprogram = (case = 5);
      35      if  case = 0  then  i = cstype_subr;
      36      elseif  case = 1  then  i = cstype_fnct;
      37      elseif  case = 5  then  i = cstype_prog;  end if;
      38      csa(1) = 0;  cstype csa(1) = i;  $ set compound statement type.
      39      flowgen = 0;  $ initialize flow trace counter
      40      csatokptr = 0;  $ ptr to -csatok- array
      41      tokorg csa(1) = 1;  $ set save token origin
      42      firstst csa(1) = 1;  $ set line number.
      43      savetoks = 0;  $ save tokens
      44      dovarptr = 0; dovarbusy = 0;  $ clear -do- variables stack
      45
      46      preludefg = no;  $ show not in prelude
      47      trentrfg = gtrentrfg; trflowfg = gtrflowfg;  $ set initial values
      48      trstorfg = gtrstorfg; chinxfg  = gchinxfg;      $ of debug flags
      49      trstorsfg = no;  chinxsfg = no;  $ clear indicators
      50      dbgcspcp = 0; dbgtspcp = 0;  $ reset debug stack pointers
      51      iovaptr = 0;  $ clear list of local io variables
      52      iotaptr = 0;  $ clear list of saved transmission items
      53      $   reset levmin and levnow since routine begins with empty
      54      $   ha and voa.
      55      levmin = 1;
      56      levnow = 1;
      57      tlistptr = 0;  $ reset temporaries list.
      58      curblock = voptr;
      59      proclineno = 1;  $ reset line number within routine.
      60      argct = 0;
      61      return;
      62
      63 /c(2)/     $ have subr/fnct name
      64      pop(a1);   $ get name
      65      new = 0;
      66      ep ha(a1) = voptr;
      67      var ha(a1) = yes;  $ variable type entry
      68      naym new = a1; $ link to ha
      69      if  fswitch = 0 then  type new = subrtyp;
      70      else type new = quant;  end if;
      71      voa(voptr) = new; voaup;  $ add entry to voa
      72      subinfo(1) = a1;     $ ptr to current subr
      73      sdsname(currsubrname, a1);   $ subrname = sds string
      74      subinfo(2) = fswitch;
      75      if  (mainprogram)  subinfo(2) = 2;
      76      if  listsw then  $ insert subr/fnct seporator or title
      77          if  listauto then  $ insert title
      78              temptitle = ''.pad.(cpw*wpc + cpw);  $ temporary title.
      79              do  i = 1 to listwdsp;  $ copy out header line.
      80                  .f. sorg temptitle - i*ws, ws, temptitle = listwds(i);
      81                  end do;
      82              do  i = 1 to 72;  $ find first non blank.
      83                  if  (.ch. i, temptitle ^= 1r )  then
      84                      call stitlr(1, (.s. i, 73-i, temptitle));
      85                      ejectl;  $ start new page.
      86                      quit do;
      87                      end if;
      88                  end do;
      89          else   $ auto-titling mode not on
      90              ejectlp(5); $ dont want only 'subr' line on page
      91              endl endl endl  $ write default seporator
      92              end if;
      93          end if;
      94      $   insert constants 0 and 1 in ha, save indices
      95      ccsyze = 1;  cclt = dectok;  ccval(1) = 0;  ccvalptr=1;
      96      ccnchars = 0;
      97      call inscon(ha_0);
      98      ccsyze = 1;  cclt = dectok;  ccval(1) = 1;  ccvalptr=1;
      99      call inscon(ha_1);
     100      nsubrs = nsubrs + 1;  $ update subroutine count
     101      nstouse = localblock;  $ use local block for new vars
     102      defnstouse = localblock;
     103      mba(localblock) = 0;  $ clear local block
     104
     105      $   since purge has cleared ha, set -mbha- fields to 0, and
     106      $   reset -used- bits for each global nameset
     107      $   (nameset is global if it is in xha)
     108
     109      do  j = 1 to mbaptr;
     110          mbha mba(j) = 0;
     111          mbused mba(j) = no;  $  not yet used in current routine
     112          mbdef mba(j) = no;  $ clear nameset definition bit
     113          mbchain mba(j) = 0;  $ clear defined variable chain
     114          end do;
     115
     116      $   nameset of same name as routine name, define new nameset,
     117      $   and set default nameset to be this nameset for this routine.
     118      if  (nsubrs=1) & (gsopt=1) then
     119          mbaptr = globalblock;  $ block for globals in first procedure
     120          nstouse = mbaptr;
     121          defnstouse = nstouse;  $ set default nameeet
     122          mba(mbaptr) = 0;
     123          .f. nameorg-cs, cs, sdsnamstr = 1r$; $ set special name for fi
     124          pushname(a1, sdsnamstr);  $ set to new name for nameset
     125          insglob(xhap, a1);  $ locate nameset name in xha
     126          xnsblk xha(xhap) = mbaptr;  $ record machine block (also index
     127      $   in mba) for new nameset.
     128          mbha mba(mbaptr) = a1;$  record ha index of nameset name
     129          mbxha mba(mbaptr) = xhap;  $ record xha index of nameset name
     130          end if;
     131
     132      if  (nsubrs=2) & (daopt=yes)  then  $ if default access on, note
     133      $   namesets defined in first procedure.
     134          do  j = 1 to mbaptr;
     135              xhap = mbxha mba(j);  $ get xha index (nonzero if global )
     136              if  (xhap=0) cont do;  $ not global machine block
     137              .f. j, 1, defaccesstab = yes;
     138              end do;
     139          end if;
     140
     141      accesstab = defaccesstab;  $ reset default access table
     142
     143      if  (nsubrs=1) & (gsopt=yes)  then  $ if first rout and gsopt,
     144          .f. mbaptr, 1, accesstab = yes;  $ must grant access to
     145          end if;  $ the global block being defined in first procedure.
     146
     147      if  crossrefoption  then
     148          crefput(ncards);  $  first line number of routine.
     149          $   write page number if listing input, else write 0.
     150          i = 0;  if  (listsw) call contlpr(12,i);
     151          crefput(i);         $ write page info.
     152          crefput((slen currsubrname));  $ length of name.
     153          size  refpos(ps), refent(ws);
     154          refpos = cpw*cs + 1;  refent = blankword;
     155          do  i = 1 to slen currsubrname;
     156              refpos = refpos - cs;
     157              .f. refpos, cs, refent = .ch. i, currsubrname;
     158              if  refpos = 1  then
     159                  crefput(refent);
     160              refpos = cpw*cs + 1;  refent = blankword;
     161                  end if;
     162              end do;
     163          if  refpos ^= (cpw*cs+1)  then crefput(refent); end if;
     164          end if;
     165      if  mainprogram  then  $ if program, generate call to ltlini.
     166          pushname(i, proc_initiate);
     167          push(ha_0);
     168          arglist(argptr) = 0;  $ one param.
     169          call gencall(call_parms);
ldse  19          $ if expire option specified, generate call to ltlced to
ldse  20          $ check expiration.
ldse  21          if  expire  then
ldse  22              $ lntime gives year in ta(1), day of year in ta(7).
ldse  23              call lntime(ta);
ldse  24              ta(1) = ta(1) + (ta(7) + expire)/365; $ expiry year.
ldse  25              ta(7) = mod(ta(7)+expire, 365);  $ expiry day of year.
ldse  26              if  (ta(7)=0)  ta(7)=1; $ avoid day 0.
ldse  27              $ generate call ltlced(year_expire, day_expire);
ldse  28              pushname(i, proc_expire);
ldse  29              pushint(ta(1));  $ year.
ldse  30              pushint(ta(7));  $ day of year.
ldse  31              arglist(argptr) = 1;  $ two args.
ldse  32              call gencall(call_parms);
ldse  33              end if;
     170          end if;
     171      testdebug;  $ see if debug code wanted
     172      pushname(a1, debugnames(dbg_subn));  $ push routine name
     173      endblock = no;  $ dont end block
     174      call sdsnamr(naym voa(voafnct));  $ get name of current routin
     175      call getxsds(a1, sdsnamstr);  $ build constant
     176      push(a1); pushint(fswitch+2*mainprogram);  $ push parms
     177      arglist(argptr) = 1;  $ show one parm
     178      call gencall(call_parms);  $ generate call
     179      if  trentrfg then  trentry(entrrout) end if;
     180      return;
     181
     182 /c(3)/    $ process arguments
     183      argct = arglist(argptr)+1;  $ number of formal arguments
     184      do  i = 0 to argct-1;
     185          a1 = arglist(argptr-argct+i); $ get argument
     186          if  ep ha(a1) then  $ argument already defined
     187              ermesarg = a1;  $ set error message number.
     188              call ermes(30); cont do;
     189              end if;
     190
     191          new = 0;  $ build voa entry
     192          ep ha(a1) = voptr; naym new = a1;
     193          type new = quant; argno new = i+1;
     194          arb new = yes;  $ show is argument
     195          isavar new = yes;  $ show cannot be function.
     196          voa(voptr) = new; voaup;
     197          end do;
     198
     199      $   fall through to terminal processing
     200
     201 /c(4)/    $ end of subr/fnct statement
     202      toknum csa(1) = savetoks;
     203      savetoks = 5;  $ do not save any more tokens
     204      if  mainprogram & (argct>0)  then  $ no args to main program
     205          call ermes(59);
     206          end if;
     207
ldsa  66 .+rep.
ldsa  67      if  rep_opt_p  then  $ if reporting procedure definitions
ldsa  68          call putrep(rep_typ, rep_typ_p);
ldsa  69          call putrep(rep_nam, subinfo(1));  $ name
ldsa  70          call putrep(rep_int, subinfo(2));  $ type
ldsa  71          call putrep(rep_int, argct);
ldsa  72          call putrep(rep_end, 0);
ldsa  73          end if;
ldsa  74 ..rep
ldsa  75
     208      end subr gensub;
       1 .=member  genuntl
       2      subr genuntl(case);  $ process -until- statement
       3
       4      $   implements an intil loop opener statement.
       5      $   if case = 1, make new csa entry of type until.
       6      $   generate a goto bodylabel entry in voa, using  routine
       7      $   gengol.
       8      $   if case = 2, definetest label and generate code for
       9      $   if...go to end label and then define bodylabel.
      10
      11      size  case(ps);          $ type of call
      12      size  blab(ps);          $ body label
      13      size  tlab(ps);          $ test label
      14      size  elab(ps);          $ end label
      15      size  csanew(csasz);   $ new coasa entry
      16
      17      go to l(case) in 1 to 2;
      18 / l(1) /
      19      labget(blab) push(blab)  call gengol(op_goto);   $ generate go to
      20      labget(tlab)   labdef(tlab)
      21      $   body label
      22      csacountup('until');    $ increment csaptr
      23      csanew = 0;   $ build new csa entry
      24      cstype csanew = cstype_until;
      25      firstst csanew = proclineno;
      26      bodylbl csanew = blab;
      27      testlbl csanew = tlab;
      28      tokorg csanew =csatokptr + 1;
      29      csa(csaptr) = csanew;
      30      return;
      31
      32 / l(2) /
      33      toknum csa(csaptr) = savetoks;
      34      savetoks = 5;    $ do not save any more tokens
      35      labget(elab)   $ generate end label
      36      push(elab) call genifgo(op_if);   $ generate if..go to elab
      37      blab = bodylbl csa(csaptr);    $ get body label, already defined
      38      labdef(blab)
      39      endlbl csa (csaptr) = elab;
      40      $   trace for debugging
      41      if  trflowfg then  trflow(flowtil) end if;
      42
      43      end subr genuntl;
       1 .=member  genwhil
       2      subr genwhil(case);  $ process -while- statement
       3
       4      $   implements a while loop opener statement.  if case = 1, make
       5      $   new entry in csa stack, flagged as a while type.
       6      $   generate a new label definition which is the test label
       7      $   if case = 2, generate code for    ifnot  go to endlabel
       8
       9      size  case(ps);          $ type of call
      10      size  csanew(csasz);   $ new entry in csa
      11      size  elab(ps);          $ end label ha ptr
      12      size  tlab(ps);          $ test label ha ptr
      13
      14      go to l(case) in 1 to 2;
      15 / l(1) /
      16      labget(tlab)   $ generate new label tlab
      17      labdef(tlab)    $ define new label
      18      csacountup('while');    $ increment csaptr
      19      csanew = 0;  $ make new entry in csa
      20      cstype csanew = cstype_while;
      21      firstst csanew = proclineno;  $ first statement of opener
      22      testlbl csanew = tlab;
      23      tokorg csanew =csatokptr + 1;
      24      csa(csaptr) = csanew;
      25      return;
      26 / l(2) /
      27      toknum csa(csaptr) = savetoks;
      28      savetoks = 5;    $ do not save any more tokens
      29      labget(elab)    $ generate end label
      30      push(elab)      $ on argument stack
      31      call genifgo(op_ifnot);
      32      endlbl csa(csaptr) = elab;
      33      $   trace for debugging
      34      if  trflowfg then  trflow(flowhil) end if;
      35
      36      end subr genwhil;
       1 .=member  genfile
       2      subr genfile;  $ process file declaration
       3
       4      $   generator for file statement.
       5      $   emits call makfile(filename, actname, attributes...)
       6      $   the actual filename is restricted to 10 characters
       7
       8      size  i(ps);  $ ha index for call generation.
       9      size  given(ps);        $ list of values given.
      10
      11      $   generate  call makf(filename, given, iofilekeys(1),
      12      $       ...,iofilekeys(4));
      13      given = 0;
      14      do  i = 1 to 4;
      15      $   if attribute given, set bit in -given.
      16      $   if attribute not given, pass constant 0 as arg.
      17          if  iofilekeys(i)  then  $ if given.
      18              .f. i, 1, given = 1;
      19          else
      20              iofilekeys(i) = ha_0;
      21              end if;
      22          end do;
      23
      24      if  given ^= 1b'010' & given ^= 1b'011' & given ^= 1b'111' then
      25          call ermes(63);  return;  $ this is an error.
      26          end if;
      27
      28      pushname(i, ionames(ior_makf));  push(iofilename);
      29      pushint(given);
      30      do  i = 1 to 4;  push(iofilekeys(i));  end do;
      31      endblock = no;  $ dont end block
      32      arglist(argptr) = 5;  call gencall(call_parms);
      33
      34      end subr genfile;
       1 .=member  geniost
       2      subr geniost(c);  $ miscellaneous io generator
       3      $   process miscellaneous io generator functions.
       4
       5      size  c(ps);  $ action code
       6      size  a1(ps); $ ha index of first arg, if present
       7      size  i(ps); $ loop index
       8      size  keycode(ps);  $ function to search string with codes.
       9
      10      go to l(c) in 1 to 12;
      11 /l(1)/ /l(2)/ $ start of put or get, indicate mode
      12      iowriting = (c=2);
      13      iovabusy = 0; $ free all io-related local variables
      14      iotaptr = 0;  $ clear list of saved transmission items
      15      iofilename = 0;
      16      return;
      17
      18 / l(3) /  $ process file name.
      19      pop(iofilename);
      20      return;
      21
      22 / l(4) /  $ 'get' or 'put' with no file given
      23      pushint(1+iowriting);  pop(iofilename);
      24      return;
      25
      26 / l(5) / / l(6) / $ indicate whether formatted or unformatted io
      27      ioformatted = (c=6);
      28      if  ioformatted  then  $ if formated, clear iops.
      29          do  i = 1 to iopsflds;
      30              iopsha(i) = ha_0;
      31              end do;
      32          end if;
      33
      34      $ generate validation request.
      35      pushname(i, ionames(ior_vali));  push(iofilename);
      36      pushint(iowriting + 2*(1-ioformatted));
      37      endblock = no; $ dont end basic block
      38      arglist(argptr) = 1; call gencall(call_parms);
      39      return;
      40
      41 / l(7) /  $ process file definition statement
      42      do  i = 1 to 4;  iofilekeys(i) = 0;  end do;
      43      go to l(3); $ to process file name
      44
      45 / l(8) / $ process attribute specifications in file statement
      46      pop(a1);
      47      $   error if attribute already given.
      48      if  (iofilekeys(iokey)) call ermes(22);
      49      if  iokey = 2  then  $ iotype
      50          if  var ha(a1) then
      51              sdsname(sdsnamstr, a1);
      52              i = keycode(sdsnamstr, $ next line gives iotype encoding
      53      '01=get 02=print 03=put 04=read 05=string 06=write 07=release ');
      54              if  (i)  go to fkey;
      55              end if;
      56
      57          $   error if not variable or bad attribute.
      58          call ermes(23); return;
      59          /fkey/
      60          pushint(i);  pop(a1); $ set a1 to ha index of i value.
      61          end if;
      62      iofilekeys(iokey) = a1;
      63      return;
      64
      65 / l(9) /  $ process rewind request
      66      pop(iofilename);
      67      pushname(i, ionames(ior_rwnd));  push(iofilename);
      68      endblock = no;  $ not end of block
      69      push(ha_0)   $ indicate no access change.
      70      arglist(argptr) = 1;  call gencall(call_parms);
      71      return;
      72
      73 / l(10) /  $ process filestat request
      74      $   generate  = ioqu(iofilename, hap)  .
      75      pop(iofilename);  $ get file id.
      76      pushname(i, ionames(ior_ioqu));  push(iofilename);
      77      pushint(iokey);
      78      ermflag = no;  $ suppress unsized function diagnostic
      79      arglist(argptr) = 1;  call gencall(call_value); ermflag=yes;
      80      return;
      81  /l(11)/  /l(12)/   $ binary io entries.
      82      iovabusy = 0;  iotaptr = 0;
      83      pop(iofilename);
      84      iowriting = (c=12);
      85      go to l(5);
      86      end subr geniost;
       1 .=member  geniotr
       2      subr geniotr; $ generate or stack transmission request
       3      $   in unformatted case, do nothing, as -genioit- will issue io
       4      $   request.
       5      $   in formatted case, call formatted data primitives for stacked
       6      $   data items. (items are stacked if multiple items with same
       7      $   format, as in ':x:y:z,i(10)'.)
       8      size  i(ps);  $ do loop index
       9      size  iopshasv(ps);  dims iopshasv(iopsflds);
      10      size  j(ps);          $ loop index.
      11
      12      if  (ioformatted=no) return;
      13
      14      $   if more than one item, must save iopsha since geniops
      15      $   clears it at end.
      16      if  iotaptr > 1  then
      17          do  j = 1 to iopsflds;  iopshasv(j) = iopsha(j);  end do;
      18          end if;
      19
      20      do  i = 1 to iotaptr;
      21          iovar = iotavar iota(i);
      22          iolo = iotalo iota(i); iohi = iotahi iota(i);
      23          call setq(iovar);
      24          if  iolo  then  call setq(iolo);  end if;
      25          if  iohi  then  call setq(iohi);  end if;
      26          if  i > 1  then  $ if must restore iopsha.
      27              do  j = 1 to iopsflds;  iopsha(j) = iopshasv(j);  end do;
      28              end if;
      29          if  iowriting
      30              then call genpdi;
      31              else call gengdi;  end if;
      32          end do;
      33
      34      ionameflag = no;
      35      iotaptr = 0;
      36
      37      end subr geniotr;
       1 .=member  genioit
       2      subr genioit(c); $ process io data item specification
       3      $   process datum to transmit.  if c=1 then have name, perhaps
       4      $   of array (implying transmission of all of array);
       5      $   if  c=2 have array slice, parsed as indexed loads.
       6
       7      size  c(ps);  $ case, 1 if single item, 2 if definite slice
       8      size  hap(ps);  $ ha index of generated entries
       9      size  a1(ps), a2(ps);  $ ha indices of arguments
      10      size  it1(voasz), it2(voasz); $ voa entries for arguments
      11      size  new(voasz);  $ new voa entry for unformatted case
      12
      13      iolo = 0;  iohi = 0;  $ assume not slice
      14
      15      if  c=1  then  $ variable or expression
      16          pop(a1); call setq(a1);
      17          it1 = voa(ep ha(a1));
      18          if  opb it1 = no  then $ variable case
      19              iovar = naym it1; $ variable to transmit
      20              if  dimn it1 then  $ entire array
      21                  iolo = ha_1;
      22                  pushint(dimn it1);  pop(iohi);
      23                  end if;
      24              else
      25              if  opcode it1 = op_xload then $ array element, set lo
      26                  iovar = naym voa(inp1 it1);
      27                  iolo = inp3 it1;
      28              else
      29                  iovar = a1;
      30                  end if;
      31              end if;
      32          end if;
      33
      34      if  c=2  then  $ array slice
      35          pop(a2); pop(a1);  $ retrieve two arguments.
      36          call setq(a1);  call setq(a2);  $ check inputs.
      37          it1 = voa(ep ha(a1)); it2 = voa(ep ha(a2));
      38          if  ((opb it1 + opb it2) ^= 2) go to baditem;
      39          if  (opcode it1 ^= opcode it2) go to baditem;
      40          if  (opcode it1 ^= op_xload) go to baditem;
      41          if  (inp1 it1 ^= inp1 it2) go to baditem;
      42          iovar = naym voa(inp1 it1); $ array being transmitted
      43          iolo = inp3 it1;  iohi = inp3 it2;
      44          if  iohi=iolo  then  iohi = 0;  end if;
      45          end if;
      46
      47
      48      if  ioformatted  then  $ build iota entry
      49          countup(iotaptr, iotamax, 'genioit');
      50          iota(iotaptr) = 0; iotavar iota(iotaptr) = iovar;
      51          iotalo iota(iotaptr) = iolo; iotahi iota(iotaptr)=iohi;
      52      else
      53          call setq(iovar);
      54          if  iolo  then call setq(iolo); isuse(iolo); end if;
      55          if  iohi  then call setq(iohi); isuse(iohi); end if;
      56          new = 0;
      57          opb new = yes; opcode new = op_io;
      58          oup new = iowriting;
      59          inp1 new = ep ha(iofilename);
      60          inp2 new = ep ha(iovar);
dss   62          isuse(iofilename);
dss   63          isuse(iovar);
dss   64          if  iolo  then inp3 new = ep ha(iolo); isuse(iolo); end if;
      62          if  iohi  then
dss   65              isuse(iohi);
      63              xarg_voa xarg(xargptr) = ep ha(iohi);
      64              argbeg new = xargptr;
      65              countup(xargptr, xargmax, 'genioit');
      66              arglen new = 1;
      67              end if;
      68          voa(voptr) = new; voaup;
      69          end if;
      70      $   if reading, terminate block since values read
      71          if  iowriting=no  then call blkend; end if;
      72          return;
      73 /baditem/  $ bad transmission item, build no iota enrytry
      74      call ermes(46);
      75
      76      end subr genioit;
       1 .=member  gencfi
       2      subr gencfi(c);  $ process control format.
       3      $   process control format, c is 0 if no parameter supplied, and
       4      $   one if parameter supplied.
       5      size  c(ps);
       6      size  a1(ps);           $ ha index of count.
       7      size  hap(ps);          $ ha index.
       8
       9      if  iokey = 5  then  $ convert title to a format output.
      10          pop(a1);
      11          iovar = a1;  iolo = 0;  iohi = 0;
      12          iokey = 1;  $ reset to key of a format.
      13          arglist(argptr) = 0;  $ no args.
dsq    9          call gendfi(0);
      15          call genpdi;
      16          return;
      17          end if;
      18      $   check that no parm given for page.
      19      if  (c) & (iokey = 3) go to err;
      20      $   if no parm given, set to one.
      21      if  c = 0  then push(ha_1);  end if;
      22      pop(a1);    $ get count.
      23      pushname(hap, ionames(ior_gcfp));
      24      push(a1); pushint(iokey);
      25      endblock = no;  $ dont end basic block
      26      arglist(argptr) = 1;  call gencall(call_parms);
      27      return;
      28 /err/
      29      ioerror = yes;
      30      call ermes(24);
      31
      32      end subr gencfi;
       1 .=member  gendfi
       2      subr gendfi(c);  $ process data format.
       3      size  c(ps);            $ zero if no args, else one if args given.
       4      size  ioara(ps);  dims ioara(3);
       5      $   maxargara gives maximum number of parameters for data
       6      $   format, as function of assigned encoding established in parse.
       7      size  maxargara(ps); dims maxargara(ioformats);
       8      data  maxargara = 2, 3, 3, 3, 3, 2;
       9      size  nargs(ps);        $ number of arguments.
      10      size  i(ps);            $ loop index.
      11
      12      ioerror = no;
      13      nargs = 0;  if  (c = 1)  nargs = arglist(argptr) + 1;
      14      if  (nargs > maxargara(iokey)) go to err;
      15      if  (iolistmode)  iopsha(iopsi_lm) = ha_1;  $ indicate list mode.
      16      if  nargs  then  $ retrieve arguments, if present.
      17          argptr = argptr - nargs;
      18          do  i = 1 to nargs;
      19              ioara(i) = arglist(argptr+i-1);
      20              end do;
      21          end if;
      22      do  i = nargs+1 to maxargara(iokey);  $ clear unspecified args.
      23          ioara(i) = ha_0;  end do;
      24      $   as first approximation to checking consistency of arguments,
      25      $   assume that the first parameter specified is field width, and
      26      $   that if maximum number of parameters is specified, then last
      27      $   is group width.  also, for formats with maximum three
      28      $   parameters, second is decimal width (e,f) or byte width (b).
      29      if  ioara(1)  then  $ first parm is always field width.
      30          iopsha(iopsi_fw) = ioara(1);
      31          end if;
      32      if  nargs = maxargara(iokey)  then  $ if group width given.
      33          iopsha(iopsi_gw) = ioara(nargs);
      34          end if;
      35      if  (nargs > 1) & (maxargara(iokey) = 3)  then  $ if dw (or bw) gi
      36          iopsha(iopsi_dw) = ioara(2);
      37          end if;
      38      iolistmode = no;
      39      return;
      40 /err/
      41      ioerror = yes;
      42      call ermes(25);
      43
      44      end subr gendfi;
       1 .=member   geniops
       2      subr  geniops;  $ generate io parm. str.
       3      size  hap(ps);          $ ha index.
       4      size  i(ps);        $ loop index.
       5      size  iopsval(iopssz);      $ constant part of parm. str.
       6      size  varorg(ps);       $ if nonzero, index of first nonconst parm
       7      size  getiov(ps);       $  get local variable for io.
       8
       9      iopsval = 0;
      10      $   if target machine word size is less than size of iops,
      11      $   iops is multiword, so set high order bit to guarantee that
      12      $   multiword parameter string obtained.
      13          if  (mws < iopssz)  then
      14              .f. iopssz, 1, iopsval = 1;
      15              end if;
      16      varorg = 0;
      17      do  i = 1 to iopsflds;
      18          hap = iopsha(i);
      19          if  (hap = ha_0)  cont do;
      20          if  hascon ha(hap)  then  $ if constant enter value.
      21              .f. iopsorg(i), iopslen(i), iopsval = conval(hap);
      22          else  $ if non constant, save loc if first.
      23              if  (varorg = 0)  varorg = i;
      24              end if;
      25          end do;
      26
      27      if  varorg  then  $ if any variables, generate assigns.
      28          iopshap = getiov(iopssz);  $ get variable.
      29          push(iopshap);  pushint(iopsval);  $ v = val.
      30          call genasin(1, no);
      31          do  i = varorg to iopsflds;
      32              hap = iopsha(i);
      33              if  (hap = ha_0) cont do;
      34              if  (hascon ha(hap)) cont do;
      35              pushint(iopsorg(i));  pushint(iopslen(i));
      36              push(iopshap);  push(hap);
      37              call genasin(2, no);
      38              end do;
      39      else  $ if all fields constant, hash in constant.
      40          pushint(iopsval);
      41          pop(iopshap);
      42          end if;
      43
      44      do  i = 1 to iopsflds;  $ reset iopsha to initial state.
      45          iopsha(i) = ha_0;
      46          end do;
      47
      48      end subr geniops;
       1 .=member  gengdi
       2      subr gengdi;   $ process -get- for a data item.
       3      $   this routine emits a call to a get data formatted routine.
       4      $   the format type is indicated by -iokey-. the arguments
       5      $   are stored in - iodfitems-.
       6      size  index(ps);         $ ha index of index
       7      size  nbts(ps);          $ number of bits
       8      size  hap(ps);           $ ha index of rout name
       9      size  datum(ps);         $ ha index of datum
      10      size  array(ps);         $ ha index of array
      11      size  dovar(ps);         $ do loop generated variable
      12      size  getiov(ps);  $ returns ha index of io local variable
      13
      14      if  (ioerror) return;      $ was a format error - supress call
      15      if  (ionameflag) call ermes(26);    $ namelist request on input
      16      index = iolo;     datum = iovar;
      17      call setq(datum);  $ check input.
      18      array = 0;
      19      nbts = syze voa(ep ha(datum));
      20
      21      if  iolo then     $ need a temporary. because of little
      22      $   linkage mechanisms, cannot pass
      23      $   indexed arrays as parameter to input.
      24      $   a temporary is passed, and stored in
      25      $   array after call.
      26          array = datum;
      27          datum = getiov(nbts); $ get io local variable
      28          dovar = 0;  $ do loop variable
      29          if  iohi  then
      30          $   issue a do loop.
      31              call gendo(1);      $ to initialize
      32              dovar = getiov(mps);  push(dovar);
      33              push(iolo); push(iohi);
      34              call gendo(2);      $ do dovar = lo to hi (no by part)
      35              index = dovar;
      36              end if;
      37          end if;
      38
      39      pushint(nbts);  pop(hap);  $ enter sz field in iops.
      40      iopsha(iopsi_sz) = hap;
      41      call geniops;  $ generate io parm. str.
      42      push(iopshap);
      43      pushname(hap, ionames(iodfprocs(iokey + ioformats*iowriting)));
      44      push(datum)   $ first parameter.
      45      push(iopshap);
      46      arglist(argptr) = 1;  $ two params.
      47      call gencall(call_parms);   $ generate call
      48      if  array  then     $ a(i) = temp
      49          push(array) push(index) push(datum)
      50          call genasin(1, 1);      $ simple index assign
      51          if  (dovar) call closer;
      52          end if;
      53
      54      end subr gengdi;
       1 .=member  genpdi
       2      subr genpdi;  $ process request to put data item
       3      $   this routine emits a call to a formatted output routine.
       4      $   the routine to be called is indicated by the value of
       5      $   -iokey-. the arguments are stored in the array -iodfitems-.
       6      $   if ionameflag is set, namelist format is specified, and a call
       7      $   routine onmlst_name is generate.
       8      size  datum(ps);         $ ha index of datum
       9      size  dovar(ps);         $ ha index of do loop variable
      10      size  ion(ps);  $ index of namelist routine to use
      11      size  nbts(ps);          $ number of bits
      12      size  hap(ps);           $ ha index of routine name
      13      size  getiov(ps);  $ get local variable for io
      14      size  array(ps);  $ ha index of array if array case
      15      size  index(ps);    $ ha index of array element whose name to list
      16
      17      if  (ioerror) return;     $ format error - supress
      18      datum = iovar;
      19      call setq(iovar);
      20      array = 0;  $ assume not transmitting array element
      21      nbts = syze voa(ep ha(iovar));
      22
      23
      24      if  iolo  then  $ if array element(s) involved
      25          array = iovar;
      26          dovar = 0;
      27          if  iohi  then $ array slice, generate do loop
      28              call gendo(1);    $ to initialize do loop
      29              dovar = getiov(mps);  $ get do loop index
      30              push(dovar)
      31              push(iolo); push(iohi);
      32              call gendo(2);           $ no by part
      33              push(iovar)  push(dovar)
      34          else   $ transmit  array(iolo)
      35              push(iovar);  push(iolo);
      36              end if iohi;
      37
      38          index = arglist(argptr-1);  $ save index in case -n- output
      39          arglist(argptr) = 0; call gencall(call_value); $ index operati
      40          pop(datum);
      41          end if iolo;
      42
      43      if  ionameflag  then  $ namelist output (for variable)
      44          if  var ha(iovar) = 0  then call ermes(27);return; end if;
      45      $   generate call onmv(nameofvariable)
      46          if  iolo
      47              then ion = ior_onma;
      48              else ion = ior_onmv;    $ simple variable case
      49              end if;
      50
      51          pushname(hap, ionames(ion));
      52          sdsname(sdsnamstr, iovar); $ get name of variable as sds
      53          call getxsds(hap, sdsnamstr);  push(hap); $ get execution form
      54          arglist(argptr) = 0;  $ one parameter.
      55          if  iolo  then  $ if array element, pass index
      56              push(index);  arglist(argptr) = 1;  end if;  $ two params.
      57      endblock = no;  $ not end of basic block
      58          call gencall(call_parms);
      59          end if ionameflag;
      60
      61      $   generate call
      62      pushint(nbts);  pop(hap);  $ enter sz field in iops.
      63      iopsha(iopsi_sz) = hap;
      64      call geniops;  $ generate io parm. str.
      65      pushname(hap, ionames(iodfprocs(iokey + ioformats*iowriting)));
      66      push(datum)  $ first parameter.
      67      push(iopshap);
      68      arglist(argptr) = 1;  $ two parameters.
      69      endblock = no;  $ dont end basic block
      70      call gencall(call_parms);   $ emit call
      71      if  (iohi) call closer;
      72
      73      end subr genpdi;
       1 .=member  getiov
       2      fnct getiov(nb);  $ get local variable for io
       3      $   obtain local variable of -nb- bits for io.  use a free one if
       4      $   available, else allocate a new local variable.
       5      size  getiov(ps);        $ ha pointer returned
       6      size  nb(ps);            $ number of bits
       7      size  v(ps);             $ ha index of variable
       8      size  i(ps);             $ -iova- index
       9
      10      do  i = 1 to iovaptr;
      11          if  (iovasize iova(i) ^= nb) cont do; $ not right size
      12          if  (.f. i, 1, iovabusy = 0)  go to exists; $ if free, assign
      13          end do;
      14
      15      $   build new entry in iova
      16      call advstr(lvgen, v);      $ get fresh variable name
      17      push(v)  pushint(nb)
      18      localforce = yes;  $ make sure gensiz uses local block
      19      call gensiz;
      20      countup(iovaptr, iovamax, 'getiov');
      21      iova(iovaptr) = 0;
      22      iovasize iova(iovaptr) = nb;
      23      iovaha iova(iovaptr) = v;
      24      i = iovaptr;
      25 /exists/
      26      .f. i, 1, iovabusy = 1;  $ mark variable as in use
      27      getiov = iovaha iova(i);
      28
      29      end fnct getiov;
       1 .=member  blkend
       2      subr blkend;   $ basic block processor
       3      $   terminate basic block.  if no instructions in block, then
       4      $   return immediately.
       5      $   for each voa item in the block:
       6      $   if the entry is an operation, obtain a temporary,
       7      $   and then for each of its inputs, check for last use of
       8      $   input in this block.  if last use found, set drop bit
       9      $   for later use by machine code generator, as after last use
      10      $   need no longer keep items in machine registers.
      11
      12      size  this(voasz);  $ copy of voa(voanow)
      13      size  sz(ps);  $ size of temporary
      14      size  retinp(ps);  $ voa index of input examined by retarg.
      15      size  i(ps);
      16      size  voanow(ps);  $ index of voa item being examined.
      17      size  opa(6);   $ opatr entry for opcode of this item.
      18      size  mode(1);  $ arithmetic mode.
      19
      20      $   the operator attributes used by blkend are encoded in the
      21      $   array opatr, indexed by op code initialized in -kind- array
      22      $   in routine start.  the attributes are as follows, where 1
      23      $   indicates attribute true for this operator class.
      24      $   te- op has value, get temporary to hold output value.
      25      $   i1- inp1 field has input
      26      $   i2- inp2 field has input.
      27      $   i3 - inp3 field has input.
      28      $   xa - -xarg- stack may have varying list of inputs.
      29      $   ou - oup field has input.
      30
      31      size  opatr(6); dims opatr(16);
      32      data  opatr =
      33      $. te   i1   i2   i3  ou  xa
      34      1b' 0    0    0    0   0   0', $ 01. return, data, etc.
      35      1b' 1    1    0    0   0   0', $ 02. unary
      36      1b' 1    1    1    0   0   0', $ 03. binary
      37      1b' 1    1    1    1   0   0', $ 04. field extract
      38      1b' 1    0    0    0   0   1', $ 05. function call
      39      1b' 0    0    0    0   0   1', $ 06. subroutine call
      40      1b' 0    1    1    0   0   0', $ 07. a1 = a2
      41      1b' 0    1    1    1   0   0', $ 08. a1(a2) = a3
      42      1b' 0    1    1    1   1   0', $ 09. .e. a1, a2, a3 = a4
      43      1b' 0    1    1    1   1   1', $ 10. .e. a1, a2, a3(a4) = a5
      44      1b' 0    1    0    0   0   0', $ 11. if, goby
      45      1b' 1    1    1    0   0   0', $ 12. real binary
      46      1b' 1    1    1    0   0   0', $ 13. real comparison
      47      1b' 1    1    0    0   0   0', $ 14. real unary
      48      1b' 0    1    1    1   0   1', $ 15. unformatted io
      49      1b' 1    0    1    0   0   0'; $ 16. indexed load
      50
      51      +*  oa_temp = .e. 06, 01, ** $ 'does oup hold value.'
      52      +*  oa_inp1 = .e. 05, 01, ** $ 'does inp1 contain input.'
      53      +*  oa_inp2 = .e. 04, 01, ** $ 'does inp2 contain input.'
      54      +*  oa_inp3 = .e. 03, 01, ** $ 'does inp3 contain input.'
      55      +*  oa_oup  = .e. 02, 01, ** $ 'does oup  contain input.'
      56      +*  oa_xarg = .e. 01, 01, ** $ 'may xarg contain inputs.'
      57
      58      $   if there are no instructions in the current block, return
      59      $   at once.  else set levmin = levnow+1.
      60      $   if  this overflows the levmin counter, go to over.
      61      $   macros used in this routine only, dropped at end
      62
      63      +*  tlist_voa   = .e. 01, 11, **  $ voa index of temporary
      64      +*  tlist_size  = .e. 12, 11, **  $ temporary length.
      65      +*  tlist_free  = .e. 23, 01, **  $ 'is temporary free.'
      66      +*  tlist_mode  = .e. 24, 01, ** $ arithmetic mode.
      67      +*  retarg(f, v, db) = $ return argument, drop field to set.
      68          retinp = f v;
      69      $   check voa entry indexed by -retinp-.  if the lastuse field of
      70      $   this entry corresponds to current voa entry (index -voanow-)
      71      $   set the drop bit -db-.  if lastuse of temporary, indicate
      72      $   the temporary no longer busy.
      73      $   if this item is a variable or constant, then set the last use
      74      $   bit (drop bit) if this entry is the last use of the item.
      75
      76      if  opb voa(retinp)  then  $ if operation, check lastuse
      77          f v = oup voa(retinp);  $ replace output pointer by temp..
      78          if  retinp + lastuse voa(retinp) = voanow & keeb voa(retinp) =
      79              no then  $ this is last use.
      80              tlist_free tlist(vbeg voa(oup voa(retinp))) = yes;
      81              db v = yes;  $ set drop bit.
      82              end if;
      83
      84      else  $ this is a variable or constant.
      85          if  varluse ha(naym voa(retinp)) = voanow then  $ drop bit set
      86              db v = yes;   $ set drop bit in -voa-.
      87              end if;
      88          end if;
      89          **
      90
      91      if  (curblock >= voptr) return;
      92
      93      levnow=levnow+1;
      94      levmin=levnow;
      95      if  (levmin >= levmax) then;
      96      $   here follows overflow sequence for
      97      $   level counter.use same sequence as asign
      98      $   make a complete pass over the entire ha array, setting
      99      $   the definition level of every variable entry referenced by an
     100      $   ha entry to 1, then set levmin = 1 and levnow = 1, go back to
     101      $   starter to perform the normal blocked procedure.
     102
     103          do  i = 1 to hamax;
     104              if  (ep ha(i) = 0)  cont do;
     105              deflev voa(ep ha(i)) = var ha(i);
     106              end do;
     107 .+haprobes   blkendreset = blkendreset+1;
     108          levmin = 1; levnow = 1;
     109          end if;
     110
     111      $   if entry voanow in the voa stack is not an operation entry,
     112      $   bypass the steps below by going to next.
     113
     114      voanow = curblock;
     115 /start/
     116      if  (opb voa(voanow)=no) go to next;
     117      this = voa(voanow);  $ copy entry
     118      sz = syze this;
     119      mode = amode this;
     120      opa = opatr(blkendtype(opcode this));
     121      if  (opa=0)  go to next;  $ if no actions, continue.
     122      if  oa_temp opa  then  $ if need output temporary
     123      $   locate free temporary of desired size on tlist, constructing
     124      $   new one if necessary.  nameset -block- contains input argument
     125      $   sz giving desired size, and -temp- which is set to voa index
     126      $   of temporary.
     127      size  new(voasz);  $ new voa entry for temporary.
     128
     129      do  i = 1 to tlistptr;
     130          if  (tlist_size tlist(i) ^= sz) cont do;
     131          if  (tlist_mode tlist(i) ^= mode)  cont do;  $ if wrong mode.
     132          if  (tlist_free tlist(i)) go to exists;
     133          end do;
     134      $   no entry found, construct new temporary.
     135      countup(tlistptr, tlistmax, 'gettemp');
     136      i = tlistptr;
     137      if  sz>szmax  then  $ if size too big, trim it.
dss   66          call ermes(70);
     142          sz = szmax; end if;
     143      tlist_size tlist(i) = sz; tlist_voa tlist(i) = voptr;
     144      tlist_mode tlist(i) = mode;
     145      new = 0;  temb new = yes;  type new = quant;
     146      vbeg new = tlistptr;  $ save tlist position.
     147      syze new = sz;
     148      amode new = mode;
     149      voa(voptr) = new; voaup;
     150 /exists/
     151          tlist_free tlist(i) = no;
     152          oup this = tlist_voa tlist(i);
     153          end if;
     154
     155      if  oa_inp1 opa  then  $ if inp1 has input
     156      $   check for lastuse of temporary.
     157          retarg(inp1, this, db1);  end if;
     158
     159      if  oa_inp2 opa  then  $ if inp2 is input
     160          retarg(inp2, this, db2);  end if;
     161
     162      if  oa_inp3 opa  then  $ if inp3 is input
     163          retarg(inp3, this, db3);  end if;
     164
     165      if  oa_oup opa  then  $ if oup has input
     166          retarg(oup, this, dboup);  end if;
     167
     168      if  oa_xarg opa  then  $ if inputs on xarg stack
     169          if  arglen this  then  $ if any inputs present
     170              do  i = argbeg this to argbeg this + arglen this - 1;
     171                  retarg(xarg_voa, xarg(i), xarg_db);
     172                  end do;
     173              end if;
     174          end if;
     175
     176      voa(voanow) = this;
     177
     178 /next/
     179      voanow = voanow+1;
     180      if(voanow < voptr) go to start;
     181
     182      curblock = voptr;
     183
     184      macdrop(retarg)
     185      end subr blkend;
       1 .=member  getdovar
       2      subr getdovar(hap, sz);  $ get variable for -do-
       3      $   this routine searches the list of variables obtained for
       4      $   bounds and indexes of -do- statements to determine if any
       5      $   may be re-used.  if not, this routine creates a new one,
       6      $   generates a -size- statement, and adds it to the list.
       7      size  hap(ps);  $ -ha- pointer
       8      size  sz(ps);   $ size to assign.
       9      size  i(ps);    $ do loop index
      10
      11      do  i = 1 to dovarptr;  $ scan list
      12          if  .f. i, 1, dovarbusy = 0 then  $ found a free one
      13              if  (dovarsz(i) ^= sz) cont do;  $ skip if wrong size.
      14              hap = dovars(i);  $ get -ha- pointer
      15              .f. i, 1, dovarbusy = yes;  $ set busy
      16              return;  $ done
      17              end if;
      18          end do;
      19
      20      $   not found, must create a new one.
      21      call advstr(lvgen, hap);  $ get new variable
      22      countup(dovarptr, dovarmax, 'dovars');
      23      dovars(dovarptr) = hap;  $ insert into list
      24      dovarsz(dovarptr) = sz;   $ set size of variable.
      25      .f. dovarptr, 1, dovarbusy = yes;  $ show in use
      26      push(hap) pushint(sz) localforce = yes; $ set for -gensiz-
      27      call gensiz;  $ size it in local block
      28
      29      end subr getdovar;
       1 .=member  sortvars
       2      subr sortvars;  $ sort and assign storage for vars.
       3      $   this routine scans each -mba- entry for namesets that are
       4      $   defined in the current routine.  it then scans the chain of
       5      $   defined variables and sorts in order of increasing total size
       6      $   (size*dimn).  then, storage is allocated for the variable.
       7      $
       8      $   the sorting method used is a list merge sort from knuth's
       9      $   algorithm 5.2.4l with the suggestion given in the answer to
      10      $   exercise 12 included.
      11      $
      12      $   the nodes for 0 and n+1 are voa(1) and voa(voptr),
      13      $   respectively, which are always available.
      14      $   the array -pq- is used for the variables -p- and -q-
      15      $   so that steps l4,l5 and l6,l7 can be written in common.
      16      $
      17      $   since the variables are chained via the -vbeg- field of the
      18      $   -voa-, it is natural to use the high order bit of this field
      19      $   to replace the positive and negative links.
      20      $
      21      $   the macro -vbegs- is the first bit position of the -vbeg-
      22      $   field and -vbegl- is the length of the -vbeg- field.  note
      23      $   that   .fb. voamax   must be less than  vbegl.
      24      $
      25 .+s66    +*  vbegs = 94 **   +*  vbegl = 12 **
dss   67 .+s32    +*  vbegs = 117 **  +*  vbegl = 12 **
dst   30 .+s37    +*  vbegs = 117 **  +*  vbegl = 12 **
utsa 299 .+s47    +*  vbegs = 117 **  +*  vbegl = 12 **
dst   31 .+s10    +*  vbegs = 109 **  +*  vbegl = 12 **
      28
      29      size  mbap(ps);  $ -mba- pointer
      30      size  s(vbegl), t(vbegl);  $ list heads
      31      size  p(vbegl);  $ temporary used in scanning list
      32      size  pq(vbegl); dims pq(2);  $ used for -p- and -q-
      33      size  x(2);  $ set to 1 or 2 to index -pq-
      34      size  addr(ps);  $ cumulative address in block
      35      size  mdr(ps);  $ address of variable in block
ldsa  76      size  nsha(ps);  $ ha index of nameset name.
      36
      37
      38      do  mbap = 1 to mbaptr;  $ process all blocks
      39          if  (mbdef mba(mbap) = 0) cont do;  $ skip if not defined
      40          $   reverse mbchains so that items
      41          $   of same volume allocated storage in increasing order.
      42          if  mbchain mba(mbap) then $ if want reversal.
      43              p = mbchain mba(mbap);  $ current start.
      44              s = vbeg voa(p);     $ first item in list.
      45              if  s  then  $ if any elements to reverse.
      46                  vbeg voa(p) = 0;  $ current head becomes tail.
      47                  while  s;  $ while elements to reverse.
      48                      t = vbeg voa(s);  $ next successor.
      49                      vbeg voa(s) = p;  $ reverse link.
      50                      p = s;  $ move to next item in list.
      51                      s = t;
      52                      end while;
      53
      54                  mbchain mba(mbap) = p;  $ new header.
      55                  end if;
      56              end if;
      57
      58          vbeg voa(1) = mbchain mba(mbap); $ set to start of list
      59          t = voptr; p = mbchain mba(mbap);  $ initialize pointers
      60          while  vbeg voa(p);  $ loop until end of chain
      61              s = vbeg voa(p);  $ point to next in the list
      62              if  madr voa(p) > madr voa(s) then  $ improper order
      63                  vbeg voa(t) = s; .f. vbegs+vbegl-1, 1, voa(t) = yes;
      64                  t = p;  $ set up new sublist
      65                  end if;
      66
      67              p = s;  $ set up for next time through
      68              end while;
      69
      70          vbeg voa(t) = 0; .f. vbegs+vbegl-1, 1, voa(voptr) = 0;
      71
      72          $   two sublists have been formed.  sort may now begin.
      73          while  1;  $ loop until sorted
      74              s = 1; t = voptr;  $ initialize for next pass
      75              pq(1) = vbeg voa(1); pq(2) = vbeg voa(voptr);  $ set heads
      76              if  (pq(2) = 0) quit while;  $ only one list - sorted
      77              while  pq(2);  $ loop until end of pass
      78                  until  pq(x) = 0 ! .f. vbegl, 1, pq(x); $ q <=0
      79                      x = (madr voa(pq(1)) > madr voa(pq(2)))+1; $ compa
      80                      .f. vbegs, vbegl-1, voa(s) = pq(x); s = pq(x);
      81                      pq(x) = vbeg voa(pq(x));  $ set to next in list
      82                      end until;
      83
      84                  vbeg voa(s) = pq(3-x); s = t;  $ set new sublist
      85                  until  pq(3-x) = 0 ! .f. vbegl, 1, pq(3-x);
      86                      t = pq(3-x); pq(3-x) = vbeg voa(pq(3-x));
      87                      end until;
      88
      89                  .f. vbegl, 1, pq(1) = no; .f. vbegl, 1, pq(2) = no;
      90                  end while;
      91
      92              .f. vbegs, vbegl-1, voa(s) = pq(1); $ clean up for
      93              .f. vbegs, vbegl-1, voa(t) = 0;     $ next pass
      94              end while;
      95
      96
      97          $   list is now sorted by length.  proceed to allocate
      98          $   storage and clean up tables.
      99          p = vbeg voa(1);  $ start of sorted list
     100          mbchain mba(mbap) = p;  $ set for -asm- (if it wants it)
     101          addr = 0;  $ set at first location in block
ldsa  77 .+rep.
ldsa  78      if  rep_opt_g  then  $ if reporting global declarations
mdsa   1          if  voanl voa(p)  then  $ if global
ldsa  80              nsha = mbha mba(mbap);  $ save ha index of nameset name
ldsa  81              end if;
ldsa  82          end if;
ldsa  83 ..rep
     102          while  p;  $ loop over all variables
     103              mdr = addr + ((syze voa(p)-1)/mws+1);  $ set to var. addre
     104
     105              $   ensure that arr(0) is in block.
     106              if  dimn voa(p) ^= 0 & addr < (syze voa(p)-1)/mws + 1 then
     107                  addr = (syze voa(p)-1)/mws + 1;  $ set to leave room.
     108                  mdr = 2*addr;   $ now set starting address.
     109                  end if;
     110
     111              addr = addr + madr voa(p);  $ set new block end address
     112              madr voa(p) = mdr;  $ set address in block
     113              if  voanl voa(p) then  $ is global, must set in -nl-
     114                  nlmadr nl(voanl voa(p)) = mdr;  $ set address in -nl-
ldsa  84 .+rep.
ldsa  85                  if  rep_opt_g  then  $ if reporting globals.
ldsa  86                      call putrep(rep_typ, rep_typ_g);
ldsa  87                      call putrep(rep_nam, naym voa(p)); $ variable name
ldsa  88                      call putrep(rep_int, syze voa(p));  $ size
ldsa  89                      call putrep(rep_int, dimn voa(p));  $ dimension
ldsa  90                      call putrep(rep_nam, nsha);  $ nameset name
ldsa  91                      call putrep(rep_int, mdr);  $ offset in block
ldsa  92                      call putrep(rep_end, 0);
ldsa  93                      end if;
ldsa  94 ..rep
     115                  end if;
     116
     117              .f. vbegs+vbegl-1, 1, voa(p) = 0;  $ ensure correct chain
     118              p = vbeg voa(p);  $ point to next in list
     119              end while;
     120
     121          mblen mba(mbap) = addr;  $ set length of nameset
ldsa  95 .+rep.
ldsa  96          $   if reporting on globals, give nameset length.
ldsa  97          if  rep_opt_g & (mbap>=globalblock)  then
ldsa  98              call putrep(rep_typ, rep_typ_n);
ldsa  99              call putrep(rep_nam, nsha);
ldsa 100              call putrep(rep_int, addr);  $ nameset length
ldsa 101              call putrep(rep_end, 0);
ldsa 102              end if;
ldsa 103 ..rep
     122          end do;
     123
     124      $   clear -voanl- fields in -voa- because some asms expect zeros.
     125      do  p = 1 to voptr-1;  $ scan -voa-.
     126          if  (opb voa(p)) cont do;  $ skip operations.
     127          voanl voa(p) = 0;  $ clear field.
     128          end do;
     129
     130      macdrop(vbegs)  macdrop(vbegl)
     131      end subr sortvars;
       1 .=member  emass
       2      subr emass(storop, nargs);  $ emit assignment statement
       3      size  a5(ps);
       4      size  storop(ps);  $ opcode giving assignment type
       5      size  new(voasz);  $ new voa entry build if needed
       6      size  a1(ps),a2(ps),a3(ps),a4(ps);
       7      $   emit subroutine for store operations
       8      $   up to four arguments
       9      size  i(ps);
      10      size  j(ps);
      11      size  nargs(ps);         $ number of arguments
      12      size  this(voasz);       $ temporary -voa- entry.
dss   68      size  subi(ps);          $ ha index of subscript if indexed assign
      13
      14      $   increment the levnow counter.  test for overflow, go to
      15      $   go to the overflow case.
      16      $   else go to simple, index, subfiel or both
      17      $   depending on the parameter n defining the type of assignment
      18      $   statement for which macro code is to be generated.
      19
      20      new = 0;
      21      levnow = levnow+1;
      22      if  levnow > levmax then
      23          do  i = 1 to hamax;
      24              if  (ep ha(i) = 0)  cont do;
      25              deflev voa(ep ha(i)) = var ha(i);
      26              end do;
      27 .+haprobes   emassreset = emassreset+1;
      28          levmin = 1; levnow = 1;
      29      end if;
      30
dss   69      subi = 0;  $ assume not indexed assignment.
dss   70
      31      go to l(nargs) in 2 to 5;
      32 / l(2) /  $ a1 = a2.
      33
      34      pop(a2); pop(a1);  $ retrieve two arguments.
      35      deflev voa(ep ha(a1)) = levnow;
      36      inp2 new = ep ha(a2);
      37      inp1 new = ep ha(a1);
      38
      39      $   we must now show that the last use of the variable to which we
      40      $   have just assigned is the last one in the basic block.
      41      if  varluse ha(a1) >= curblock then  $ last used in this block.
      42          this = voa(varluse ha(a1));   $ get -voa- entry.
      43          j = ep ha(a1);   $ get -voa- index for variable.
      44          if  (inp1 this = j) db1 this = yes;  $ set drop bit.
      45          if  (inp2 this = j) db2 this = yes;
      46          if  (inp3 this = j) db3 this = yes;
      47          if  (oup this = j) dboup this = yes;
      48          voa(varluse ha(a1)) = this;  $ replace entry.
      49          if  arglen this then  $ check any arguments.
      50              do  i = argbeg this to argbeg this + arglen this - 1;
      51                  if  (xarg_voa xarg(i) = j) xarg_db xarg(i) = yes;
      52                  end do;
      53              end if;
      54          end if;
      55
      56      isuse(a1);  isuse(a2);  go to rest;
      57
      58 / l(3) /  $  a1(a2) = a3
      59      pop(a3); pop(a2); pop(a1);  $ retrieve three arguments.
      60      deflev voa(ep ha(a1)) = levnow;
      61      inp1 new = ep ha(a1);
      62      inp2 new= ep ha(a3);
      63      inp3 new= ep ha(a2);
      64      isuse(a1); isuse(a3);
      65      isusenot = hascon ha(a2);  $ dont count if constant.
      66      isuse(a2);  isusenot = no;  $ flag and reset.
dss   71      subi = a2;  $ a2 is subscript.
      67      go to rest ;
      68 / l(4) /  $  .e. a1, a2, a3 = a4
      69      pop(a4); pop(a3); pop(a2); pop(a1);
      70      if  (a2=ha_0)  return;  $ if length zero, op is no-op.
      71      deflev voa(ep ha(a3)) = levnow;
      72      isuse(a3); isuse(a4);
      73      isusenot = hascon ha(a1);  isuse(a1);  $ count unless constant.
      74      isusenot = hascon ha(a2);  isuse(a2);  $ count this unless constan
      75      isusenot = no;  $ reset flag.
      76      inp1 new = ep ha(a3);
      77      inp2 new = ep ha(a4);
      78      inp3 new = ep ha(a1);
      79      oup new = ep ha(a2);
      80      bytaln new = chasflg;  $ set character mode flag
      81      chasflg = no;  $ clear for next time
      82      go to rest;
      83
      84 / l(5) /  $ .e. a1, a2, a3(a4) = a5
      85      pop(a5); pop(a4); pop(a3); pop(a2); pop(a1); $ retrieve five argum
      86      if  (a2=ha_0)  return;  $ if length zero, op is no-op.
      87      isuse(a3); isuse(a5);
      88      isusenot = hascon ha(a1);  isuse(a1);
      89      isusenot = hascon ha(a2);  isuse(a2);
      90      isusenot = hascon ha(a4);  isuse(a4);
      91      isusenot = no;   $ reset flag.
      92      deflev voa(ep ha(a3)) = levnow;
      93      inp1 new= ep ha(a3);
      94      inp2 new= ep ha(a5);
      95      inp3 new= ep ha(a4);
      96      oup  new= ep ha(a2);
      97      bytaln new = chasflg;  $ set character mode flag
      98      chasflg = no;  $ reset
      99      xarg(xargptr) = 0;
     100      xarg_voa xarg(xargptr)=ep ha(a1);
     101      argbeg new= xargptr;
     102      arglen new = 1;
     103      countup(xargptr, xargmax, 'xarg');
dss   72      subi = a4;  $ a4 is subscript.
     104
     105 /rest/
dss   73      if  subi  then  $ check if subscript size ok.
dss   74          i = syze voa(ep ha(subi));
dss   75          if  (cis_opt>0 & i>cis_opt)  call ermes(71);
dss   76          end if;
dss   77
     106      opb new = yes;
     107      opcode new = storop;
     108      voa(voptr)=new;
     109      voaup;
     110
     111      end subr emass;
       1 .=member  emcall
       2      subr emcall(n,ki,resat, argbase);  $ build voa entry for call.
       3      $   construct voa entry for subroutine or function call,
       4      $   with arguments kept in xarg array.  note argument uses.
       5      $   for a function call, locate a free ha entry and then
       6      $   set it to represent function value.
       7
       8      size  n(ps);  $ number of parameters.
       9      size  resat(ps);
      10      size  argbase(ps);      $ arglist index of inputs.
      11      size  ki(ps);
      12      size  i(ps);  $ do loop temporary
      13      size  hcode(ps);   $ hash-code for ha function search
      14      size  j(ps), k(ps);
      15      size  new(voasz);
      16      size  this(voasz);   $ for last use values.
      17
      18      new = 0;
      19      opb new = yes;
      20      opcode new = ki;
      21      inp3 new = proclineno;  $ record line no of call statement
      22
      23      if  n  then  $ if any arguments.
      24          arglen new = n;
      25          argbeg new = xargptr;
      26          if  (xargptr+n)>xargmax  then
      27              call ermes(8);
      28              call genexit;   $ overflow case.
      29              end if;
      30
      31          do  i = 1 to n;  $ put argument pointers into xarg
      32              xarg(xargptr+i-1) = 0;  $ clear -xarg- entry
      33              call setq(arglist(argbase+i));  $ ensure sized.
      34              xarg_voa xarg(xargptr+i-1) = ep ha(arglist(argbase+i));
      35
      36              $   now set the last use bit for this prior useage of
      37              $   any arguments.
      38              if  var ha(arglist(argbase+i)) then  $ is a variable or co
      39                  if  varluse ha(arglist(argbase+i)) >= curblock then
      40                      this = voa(varluse ha(arglist(argbase+i)));
      41                      j = ep ha(arglist(argbase+i));
      42                      if  (inp1 this = j) db1 this = yes;
      43                      if  (inp2 this = j) db2 this = yes;
      44                      if  (inp3 this = j) db3 this = yes;
      45                      if  (oup this = j) dboup this = yes;
      46                      voa(varluse ha(arglist(argbase+i))) = this;
      47                      if  arglen this then
      48                          do  k = argbeg this to argbeg this +
      49                              arglen this - 1;  $ all args.
      50                              if  (xarg_voa xarg(k) = j)
      51                                  xarg_db xarg(k) = yes;
      52                              end do;
      53                          end if;
      54                      end if;
      55                  end if;
      56              end do;
      57
      58          xargptr = xargptr + n;
      59          isusenot = yes;  $ dont count arguments.
      60          do  i = 1 to n;  $ process all arguments.
      61              isuse(arglist(argbase+i));
      62              end do;
      63
      64          isusenot = no;
      65          end if;
      66
      67      naym new = arglist(argbase);
      68      syze new = syze voa(ep ha(arglist(argbase)));
dsy    9      deflev new = levnow;  $ set definition level
ldsa 104 .+rep.
dsx   37
ldsa 105      $   if rep_opt_c selected, report call. arguments are name of
ldsa 106      $   caller, name of called procedure, and number of arguments.
ldsa 107      if  rep_opt_c  then
ldsa 108          call putrep(rep_typ, rep_typ_c);  $ call
ldsa 109          call putrep(rep_nam, subinfo(1));  $ caller name
ldsa 110          call putrep(rep_nam, arglist(argbase));  $ called name
ldsa 111          call putrep(rep_int, n);
ldsa 112          call putrep(rep_end, 0);
ldsa 113          end if;
ldsa 114 ..rep
      69 /ret/
      70      if  (ki = op_call) go to calcase;
      72
      73      $   locate empty ha-slot to correspond to returned function value
      74      hcode = arglist(argbase);  $ use ha index fo hash-code
      75      haprobe(i, hcode);
      76          if  (hainuse ha(i) = no) haquit;
      77          haend;
      78
      79      hainuse ha(i) = yes;
      80      ep ha (i) = voptr;
      81      amode new = amode voa(ep ha(arglist(argbase)));
      82      resat = i;  voa(voptr) = new;  voaup;
      83      return;
      84
      85 /calcase/
      86      seblk new = endblock;  voa(voptr) = new;  voaup;
      87      if  endblock = no then
      88          endblock = yes;
      89      else call blkend;     end if;
      90      resat = 0;
      91
      92      end subr emcall;
       1 .=member  emit1
       2      subr emit1(op,a1,resat);  $ give voa entry for unary operation
       3      size  a1(ps);
       4      size  resat(ps);
       5      size  op(ps);
       6      size  j(ps);            $ ha index during search
       7      size  hcode(ps);   $ hash code to begin search
       8      size  sz(ps); $ size of result
       9      size  new(voasz);  $ new voa entry built here if needed
      10      size  def1(ps), defj(ps); $ deflev values.
      11      hcode = a1 * op;        $ random value from inputs
      12      haprobe(j, hcode);  $ search the ha
      13          if  (hainuse ha(j) = no) go to notfound;
      14          if  (var ha(j)) hacont;  $ ignore variables
      15          if  (ep ha(j) = 0) hacont; $ ignore if not iv voa
      16          if  (deflev voa(ep ha(j)) < levmin) go to notfound;
      17          if  (opcode voa(ep ha(j)) ^= op) hacont;
      18          if  (inp1 voa(ep ha(j)) ^= ep ha(a1)) hacont;
      19          go to found;  $ formally identical op. found
      20      haend;  $ end ha probe
      21 /found/
      22      def1 = deflev voa(ep ha(a1)); defj = deflev voa(ep ha(j));
      23      if  (defj < def1)  go to notfound; $ arg reassigned.
      24      if  var ha(a1) = no  then $ if op, must be avail in this block.
      25          if  (def1 < levmin)  go to notfound;
      26          end if;
      27      resat = j;  $ redundant calculation.
      28      return;
      29 /notfound/
      30      new = 0;
      31      deflev new = levnow;
      32      opcode new = op;
      33      inp1 new = ep ha(a1);
      34      opb new = yes;
      35      if  realopcd(op) then  $ mode is real
      36          sz = rlsz;  $ size of real
      37          amode new = amode_real;  $ set to real.
      38      elseif  op = op_nb ! op = op_fb then
      39          sz = mps;  $ these return pointer size
      40      elseif builtin(op)  then sz = mws;
      41      else
      42          sz = syze voa(ep ha(a1));
      43          end if;
      44
      45      syze new = sz;
      46      hainuse ha(j) = yes;
      47      ep ha(j)=voptr;
      48      isuse(a1);
      49      voa(voptr) = new;  voaup;
      50      resat = j;
      51
      52      end subr emit1;
       1 .=member  emit2
       2      subr emit2(op,a1,a2,resat);  $ give voa entry for binary operation
       3      size  a1(ps);
       4      size  a2(ps);
       5      size  op(ps);
       6      size  sz(ps);  $ size of result
       7      size  sz1(ps), sz2(ps); $ sizes of inputs
       8      size  c1(ps), c2(ps);  $ string capacities for size of !!.
       9      $   (the input arguments and the result arguments are all ha
      10      $   item references).
      11      size  j(ps);
      12      size  k(ps);
      13      size  resat(ps);
      14      size  new(voasz);  $ new voa entry built here if needed
      15      size  hcode(ps);   $ hash-code for search
      16      $   check to see if this opcode represents a commutative
      17      $   operation.
      18      $   if  it does, rearrange arguments so that the argument with
      19      $   the largest voa pointer appears as first argument.
      20      if  commutes(op)  then
      21          if  ep ha(a1) > ep ha(a2) then  $ reorder
      22              j=a1;  a1=a2;  a2=j;  end if;
      23          end if;
      24      $   search the ha array, beginning at a random
      25      $   location determined by the opcode and inputs, bypassing
      26      $   all entries of variable type.
      27      $   search wil find either empty location, or reference to a
      28      $   formally identical operation.
      29
      30      hcode = op + a1 + a2;  $ random bits from inputs
      31      haprobe(j, hcode);
      32          if  (hainuse ha(j) = no) go to notfound;
      33          if  (var ha(j)) hacont;  $ ignore variables
      34          if  (ep ha(j) = 0) hacont;  $ ignore if not in voa
      35      $   if op of previous block, reuse entry
      36          if  (deflev voa(ep ha(j)) < levmin) go to notfound;
      37          if  (opcode voa(ep ha(j)) ^= op) hacont;
      38          if  (inp1 voa(ep ha(j)) ^= ep ha(a1)) hacont;
      39          if  (inp2 voa(ep ha(j)) ^= ep ha(a2)) hacont;
      40          go to found;  $ formally identical op.
      41      haend;  $ end ha search
      42 /found/
      43      size  defent(ps), defen1(ps), defen2(ps);
      44      defent=deflev voa(ep ha(j));  defen1=deflev voa(ep ha(a1));
      45      defen2=deflev voa(ep ha(a2));
      46      if  (defent < defen1)  go to notfound; $ if first input changed.
      47      if  (defent < defen2)  go to notfound; $ if second input changed.
      48      $   inputs which are operations must have been computed
      49      $   in the current block.
      50      if  var ha(a1) = no  then
      51          if  (defen1 < levmin)  go to notfound;  end if;
      52      if  var ha(a2) = no  then
      53          if  (defen2 < levmin)  go to notfound;  end if;
      54      resat = j;  $ operation is redundant.
      55      return;
      56
      57 /notfound/
      58      sz = 0;  $ becomes nonzero when size of result known
      59      new=0;
      60      opcode new=op;
      61      deflev new = levnow;
      62      $   real operations have size 1 for comparison, size mws
      63      $   for integer-valued functions, and otherwise size rlsz.
      64      if  realopcd(op)  then  $ if real operation.
      65          if  realcomparison(op)  then  $ if comparison,
      66              sz = 1;  $ set size to 1.
      67          else
      68              sz = rlsz;
      69              amode new = amode_real;
      70              end if;
      71      elseif  builtin(op) then  $ if built-in function
      72          sz = mws;  $ size of integer.
      73          end if;
      74      $   now if fetching indexed real quantity,
      75      $   set amode field to amode_real
      76      if  op = op_xload & amode voa(ep ha(a1)) = amode_real  then
      77          amode new = amode_real;
      78          sz = rlsz;  $ size of real.
      79          end if;
      80      inp1 new=ep ha(a1);
      81      inp2 new=ep ha(a2);
      82      opb new=yes;
      83      isuse(a2);  isuse(a1);
      84      if  op=op_xload  then  $ if indexed load
      85          inp3 new = a2;  $ save ha index of subscript
dss   78          $  report warning if size greater than index size.
dss   79          if (cis_opt>0 & syze voa(inp2 new)>cis_opt)  call ermes(71);
      86          end if;
      87
      88      if  sz=0  then $ if size not yet known, compute it
      89          sz1 = syze voa(inp1 new);
      90          sz2 = syze voa(inp2 new);
      91      $   set syze as max of input sizes
      92          sz = sz1; if sz=op_gt)&(op<=op_ne)  then
dst   33              sz = 1;  $ comparison
dst   34              if  arithcomparison(op)  then  $ check operand sizes.
dst   35                  if  (sz1>mws ! sz2>mws)  call ermes(5);
dst   36                  end if;
      94          elseif  op=op_seq ! op=op_sne  then  sz = 1; $ string comparis
      95          elseif  (op=op_in)  then sz = msl;  $ .in.
      96      $   for .in., use length of sds length field.
      97          elseif  op = op_ccat  then $ if string concatenation.
      98          $   each input contains descriptor fields and only need
      99          $   one set of descriptor fields in result.
     100              if  sz1>=(msl+mso) & sz2>=(msl+mso)  then
     101                  sz = (sz1 + sz2 + mws - 1 - msl - mso)/mws * mws;
     102              else
     103                  call ermes(64);  $ print error.
     104                  sz = sz1 + sz2;  $ if either short, take sum.
     105                  end if;
     106
     107          elseif  op=op_mul  then    $ if multiplication
     108              if  (sz1<=mws)&(sz2<=mws) then $ take max if both <=mws
     109                       $ on s16, force size up to ws.
     110                      if  (targetmachine = m16)  sz = mws;
     111                  else  sz = sz1+sz2;
     112                  end if (sz1;
     113          elseif  op=op_xload  then  sz = sz1;
     114              end if;
     115          end if sz=0;
     116
     117      syze new = sz;
     118      hainuse ha(j) = yes;
     119      ep ha(j)=voptr;
     120      resat = j;
     121      voa(voptr)=new;  voaup;
     122
     123      end subr emit2;
       1 .=member  emit3
       2      subr emit3(op,a1,a2,a3,resat);  $ construct voa entry for extract.
       3      size  a1(ps);
       4      size  a2(ps);
       5      size  a3(ps);
       6      size  k(ws);
       7      size  resat(ps);
       8      size  op(ps);
       9      size  new(voasz);        $ used to build new voa fentry
      10      size  hcode(ps);   $ hash code computed
      11      size  j(ps);            $ ha index during search
      12      size  sz(ps);  $ size of extractor
      13      size  con(ps);   $ value if length of extracter is constant
      14      size  defent(ps), defen1(ps), defen2(ps), defen3(ps);
      15      $   emit subroutine for triadic(extract)op
      16      hcode = (op .ex. a1) * (a2 .ex. a3);  $ hash inputs
      17      haprobe(j, hcode);  $ search the ha
      18          if  (hainuse ha(j) = no) go to notfound;
      19          if  ( var ha(j)) hacont;  $ ignore variables
      20          if( ep ha(j) = 0) hacont; $ ignre if no voa item
      21          if  (deflev voa(ep ha(j)) < levmin) go to notfound;
      22      $   reuse op from pevious basic block
      23          if  (opcode voa(ep ha(j)) ^= op) hacont;
      24          if  (inp1 voa(ep ha(j)) ^= ep ha(a1)) hacont;
      25          if  (inp2 voa(ep ha(j)) ^= ep ha(a2)) hacont;
      26          if  (inp3 voa(ep ha(j)) ^= ep ha(a3)) hacont;
      27          go to found;  $ formally identical op. found.
      28      haend;  $ end ha probe
      29 /found/
      30      $   the operation is formally redundant, now check that no
      31      $   inputs of type operation have been redefined since the prior
      32      $   calculation, and that both the operation and any
      33      $   operation-type inputs have been computed in the current
      34      $   basic block.
      35
      36      defent = deflev voa(ep ha(j)); defen1 = deflev voa(ep ha(a1));
      37      defen2 = deflev voa(ep ha(a2));  defen3 = deflev voa(ep ha(a3));
      38      if  (defent < defen1)  go to notfound;
      39      if  (defent < defen2)  go to notfound;
      40      if  (defent < defen3)  go to notfound;
      41      $   inputs have not changed, see if inputs available in block.
      42      if  var ha(a1) = no  then $ if a1 is op.
      43          if  (defen1 < levmin)  go to notfound;  end if;
      44      if  var ha(a2) = no  then  $ if a2 is op.
      45          if  (defen2 < levmin)  go to notfound;  end if;
      46      if  var ha(a3) = no  then  $ if a3 is op.
      47          if  (defen3 < levmin)  go to notfound;  end if;
      48      resat = j;  $ operation is redundant.
      49      return;
      50
      51 /notfound/
      52      new = 0;
      53      opcode new = op;
      54      deflev new = levnow;
      55      inp1 new = ep ha(a1);
      56      inp2 new = ep ha(a2);
      57      inp3 new = ep ha(a3);
      58      isuse(a3);
      59      isusenot = hascon ha(a1);  isuse(a1);
      60      isusenot = hascon ha(a2);  isuse(a2);
      61      isusenot = no;
      62      opb new = yes;
      63      bytaln new = chexflg; $ set character mode flag
      64      chexflg = no;  $ clear for next time
      65      $   compute size of result, exploiting length if constant
      66      con = 0;
      67      if  hascon ha(a2)  then  $ if length is constant,put in con.
      68          con = conval(a2);  end if;
      69
      70      sz = 0;
      71      if  op=op_fext  then  $ if .f. extract,
      72      $   use length if is constant, else word size.
      73          if  con
      74              then  sz = con;
      75              else  sz = mws;  end if;
      76      elseif  op=op_eext  then  $ if .e. extract,
      77      $   use length if is constant, else size of source.
      78              if  (con)  sz = con;
      79      elseif  op=op_sext  then  $ if .s. extract,
      80      $   use length of appropriate sds if constant, else source size.
      81         if  con  then
      82              sz = mws*((con*mcs + msl + mso + mws-1)/mws);
      83              end if;
      84          end if;
      85
      86      if  (sz=0)  sz = syze voa(ep ha(a3));
      87      syze new = sz;
      88      hainuse ha(j) = yes;
      89      ep ha(j)=voptr;
      90      resat = j;
      91      voa(voptr)=new;  voaup;
      92
      93      end subr emit3;
       1 .=member  setlabl
       2      subr setlabl(h, labnum);  $ note use as label
       3
       4      $   this routine receives as input an ha pointer -h- and returns
       5      $   a label number 'labnum'.  it first checks the 'labno' field
       6      $   in the ha , which if non-zero, indicates that the
       7      $   label has been used previously.  in this case, it returns this
       8      $   labno.  otherwise, the lablist ptr is incremented, and its new
       9      $   value is recorded in the ha and returned as the labnum.
      10
      11      size  h(ps);             $ ha pointer
      12      size  labnum(ps);        $ label number
      13
      14      labnum = labno ha(h);      $ retur  if use as label already noted
      15      if  (labnum) return;
      16      $   label not used before
      17      countup(lablistptr, lablistlen, 'setlabl');
      18      labno ha(h) = lablistptr;      $ note that name has use as label
      19      lablist(lablistptr) = 0;
      20      labha lablist(lablistptr) = h;     $ link to ha
      21      labnum = lablistptr;         $ record label number
      22
      23      end subr setlabl;
       1 .=member  setq
       2      subr setq(a);  $ check validity as input.
       3      $   verify that ha(a) represents an item which can receive
       4      $   or produce a value.  if the item is a accessible global
       5      $   variable not yet in the ha, use the information saved
       6      $   in xha and nl to construct new voa entry.
       7      $   in any event, if cannot locate item, create a local
       8      $   variable of word-size, to help user continue in
       9      $   the absence of the size declaration.
      10
      11      size  i(ps);  $ do loop index
      12      size  a(ps);
      13      size  new(voasz);  $ for building new voa item
      14      size  xhax(ps);  $ pointer to xha, non zero for global
      15      size  nlp(ps);  $ pointeg to nl
      16      $   test to see if quantity or calc.if so, ok
      17      $   set used and set lastdef
      18      $   if  other, then error
      19      if  (var ha(a) = no) go to ret;
      20      if  (ep ha(a) ^= 0 & type voa(ep ha(a)) = quant) go to checksiz;
      21      $   encountered unsized variable,
      22      $   first see if global, and if so, page into ha
      23      ifaglob(xhax, a)   $ see if global
      24      if(xhax=0) go to er;  $ not global variable, report error
      25      $   now page in var from global names list
      26      nlp = nlno xha(xhax);  $ nl org
      27      ep ha(a) = voptr;  $ build new voa entry
      28      tracef ha(a) = nltrac nl(nlp); $ flag to trace stores
      29      chinxf ha(a) = nlchinx nl(nlp); $ flag to check index range
      30      $   check for special trace/check
      31      if  (trstorsfg)  tracef ha(a) = trstorfg; $ set if trace/notrace g
      32      if  (chinxsfg)  chinxf ha(a) = chinxfg;   $ set if check/nocheck
      33      do  i = 1 to dbgcspcp;  $ check 'check' stack
      34          if  dbgcspc(i) = a then  $ found
      35              dbgcspc(i) = 0;  $ clear place
      36              chinxf ha(a) = .f. i, 1, dbgcspcf;  $ get special value
      37              end if;
      38          end do;
      39
      40      do  i = 1 to dbgtspcp;  $ check 'trace' stack
      41          if  dbgtspc(i) = a then  $ found
      42              dbgtspc(i) = 0;   $ clear place
      43              tracef ha(a) = .f. i, 1, dbgtspcf;  $ get special value
      44              end if;
      45          end do;
      46
      47      new = 0;
      48      type new = quant;
      49      mblk new = nlblk nl(nlp); madr new = nlmadr nl(nlp);
      50      syze new = nlsize nl(nlp); dimn new = nldimn nl(nlp);
      51      naym new = a;  $ link to ha
      52      amode new = nlamode nl(nlp);
      53      voanl new = nlp;  $ point to -nl-.
      54      isafnct new = nlfnct nl(nlp);  $ set function flag.
      55      voa(voptr) = new;  voaup;
      56      return;
      57
      58 /er/
      59      ermesarg = a; if  (ntexterr = no) call ermes(7); $ report unsized
      60      push(a) pushint(mws) localforce = yes;  $ set up for -gensiz-
      61      call gensiz;  $ generate size statemant for variable
      62
      63 /checksiz/
      64      if  (syze voa(ep ha(a)) = 0) go to er;  $ not sized but in -voa-.
      65
      66      $   ensure that this is not a function being used as a variable.
      67      if  isafnct voa(ep ha(a)) & setqfok = no then  $ if function.
      68          ermesarg = a;  call ermes(66);  $ print error.
      69          isafnct voa(ep ha(a)) = no;  $ no longer function.
      70          end if;
      71
      72      setqfok = no;  $ clear special case flag.
      73
      74 /ret/
      75
      76      end subr setq;
       1 .=member  isusep
       2      subr isusep(hap); $ note use of ha(hap) as input
       3      $   macro -isuse- expands into call to this routine.
       4      $   if ha(hap) is operation, update lastuse field to reflect use.
       5      $   else, add to usage count until overflow and set last use.
       6      size  hap(ps);    $ ha index of item
       7      size  vop(ps);    $ voa index of ha(hap)
       8
       9      vop = ep ha(hap);
      10      if  var ha(hap) then  $ entry is variable or constant
      11          varluse ha(hap) = voptr; $ set last use
      12          isavar voa(vop) = yes;  $ show usage as variable.
      13          if  (isusenot) return;  $ done if no count.
      14          if  (varnuse voa(vop)+1 <= varnusemax)
      15              varnuse voa(vop) = varnuse voa(vop) + 1;
      16          return;
      17          end if;
      18
      19      if  voptr-vop <= blockmax then  $ if lastuse in range.
      20          lastuse voa(vop) = voptr-vop;  $ set it.
      21      else    $   not in range.
      22          keeb voa(vop) = yes;  $ set overflow bit.
      23          end if;
      24
      25      end subr isusep;
       1 .=member putrep
       2 .+rep.
       3      subr putrep(typ, n);  $ put entry to report file
       4 $    if report file selected, write entry to report file.
       5      size  typ(ps);  $ typ of entry to be written
       6      size  n(ws);    $ integer value or ha index to write.
       7      size  typltrs(.cs.); dims typltrs(rep_typ_max);
       8      data typltrs(rep_typ_c) = 1rc;
       9      data typltrs(rep_typ_g) = 1rg;
      10      data typltrs(rep_typ_n) = 1rn;
      11      data typltrs(rep_typ_p) = 1rp;
      12
      13      size nargs(ps);   $ number of arguments written
      14
      15      if  typ = rep_typ  then  $ if start of line
      16          put repfile ,x(8) :typltrs(n),r(1) ,x(7);
      17          nargs = 0;
      18      elseif typ = rep_int then
      19          if nargs then put repfile ,','; end;
      20          nargs = nargs + 1;
      21          put repfile :n,i;  $ write integer value
      22      elseif typ = rep_nam  then  $ if want name, n is ha index
      23          if  nargs  then  put repfile ,','; end;
      24          nargs = nargs + 1;
      25          call sdsnamr(n);
      26          put repfile :sdsnamstr,a;
      27      elseif  typ = rep_end  then  $ if end of line
      28          put repfile ,skip;
      29          end if;
      30      end subr putrep;
      31 ..rep
       1 .=member  purge
       2      subr purge;  $ cleanse tables, prepare for next routine
       3
       4      $   reset all stacks and clear the ha.  collect statistics on
       5      $   table usage.
       6
       7      size  haused(ps);  $ no of ha entries used in routine
       8      size  i(ps);
       9
      10      haused = 0;
      11      do  i =  1 to  hamax;  $ count ha load and clear ha
      12          if  (hainuse ha(i)) haused = haused+1;
      13          ha(i) = 0;
      14          end do;
      15
      16      if  haused>loadha then
      17          loadha = haused; loadrha = currsubrname; end if;
      18      if  namesptr > loadnames then   $ update max load
      19          loadnames = namesptr; loadrnames = currsubrname; end if;
      20      namesptr = 1;    $ reset names ptr
      21      if  voptr > loadvoa then $ update voa load count
      22          loadvoa = voptr; loadrvoa = currsubrname; end if;
      23      voptr = voafnct;  $ reset voa for start of definition
      24      curblock = voptr;  $ set current block to start.
      25
      26      $   reset xargptr,voptr to next available locations
      27      if  xargptr > loadxarg then   $ update xarg load
      28          loadxarg = xargptr; loadrxarg = currsubrname; end if;
      29      if  valptr > loadval then  $ update val load
      30          loadval = valptr; loadrval = currsubrname; end if;
      31      valptr=1;
      32      xargptr=1;
      33      if  lablistptr > loadlablist then  $ update lablist load
      34          loadlablist = lablistptr; loadrlablist = currsubrname; end if;
      35      lablistptr = 0;         $ reset label list origin
      36      if  tlistptr>loadtlist  then $ if new tlist load seen,
      37          loadtlist = tlistptr;
      38          loadrtlist = currsubrname;  end if;
      39      levmin = 1;  levnow = 1;
      40      lvgen = 'v.aa';  labgen = 'l.aa';
      41      $ reset local name and label names
      42      argptr = 1; arglist(argptr)=0; $ clear arglist
      43
      44      $   show in prelude for monitoring statements.
      45      preludefg = yes;  $ show in prelude.
      46      accesstab = 0;  $ show no accesses in effect.
      47      do  i = 1 to mbaptr;  $ now set all accesses to allow trace statem
      48          .f. i, 1, accesstab = yes;   $ set bit to allow variables.
      49          end do;
      50
      51      end subr purge;
       1 .=member  gentrace
       2      subr gentrace(fg, case);  $ process debug 'trace' statement.
       3      $   this generator is called for trace ,notrace debug statements.
       4      $   and also for check index.
       5      $   the cases are the following -
       6      $   1 - flow      2 - flow with subr name list
       7      $   3 - store     4 - store with variable name list
       8      $   5 - entry     6 - entry with subr name list
       9      $   7 - index     8 - index with variable name list
      10      size  nargs(ps);         $ number of names in namelist
      11      size  fg(1);  $ flag - argument
      12      size  case(ps);  $ case of call - argument
      13      size  xnl(ps);    $ index in nl
      14      size  xhax(ps);          $ ptr to xha
      15      size  hap(ps);
      16      size  i(ps), j(ps);  $ do loop indexes
      17
      18      testdebug;  $ exit if debugging not wanted
      19      if  preludefg then  $ this is global
      20          go to p(case) in 1 to 8;
      21      else
      22          go to l(case) in 1 to 8;
      23          end if;
      24
      25 / p(1) /  $ trace/notrace flow
      26      gtrflowfg = fg;  $ set global flow flag
      27      return;
      28 / p(3) /  $ trace/notrace stores
      29      do  i = 1 to nlptr;  $ change all trace bits
      30          nltrac nl(i) = fg;  $ set flag
      31          end do;
      32      gtrstorfg = fg;  $ set global flag
      33      return;
      34 / p(7) /  $ check/nocheck index
      35      do  i = 1 to nlptr;  $ change all check bits
      36          nlchinx nl(i) = fg;  $ set flag
      37          end do;
      38      gchinxfg = fg;  $ set global flag
      39      return;
      40 / p(5) /  $ trace/notrace entry
      41      gtrentrfg = fg;  $ set global flag
      42      return;
      43 / p(4) /    / p(8) /  $ trace/notrace/check/nocheck with name list
      44      nargs = arglist(argptr)+1; $ get no. of args
      45      argptr = argptr-nargs;  $ reset pointer to -arglist-
      46      do  i = 0 to nargs-1;  $ process each arg
      47          hap = arglist(argptr+i);
      48          ifaglob(xhax, hap);  $ see if global
      49          if  xhax then  $ it is in -xha-
      50              xnl = nlno xha(xhax);  $ get -nl- entry
      51              if  case > 6 then  nlchinx nl(xnl) = fg;
      52              else  nltrac nl(xnl) = fg; end if;
      53          else
      54              ermesarg = hap; call ermes(51);
      55              end if;
      56          end do;
      57      return;
      58 / l(1) /  $ trace flow and notrace flow statements
      59      trflowfg = fg;
      60      return;
      61 / p(2) /     / p(6) /
      62 / l(2) /     / l(6) /   $ trace/notrace entry/flow with namelist
      63      call ermes(58);   $ this is an error
      64      return;
      65 / l(5) /  $ trace entry and notrace entry statements
      66      trentrfg = fg;
      67      return;
      68 / l(3) /  $ trace store and notrace store statements
      69      trstorsfg = yes; $ show statement occured
      70      dbgtspcp = 0;  $ clear exception stack
      71      trstorfg = fg;
      72      do  i = 1 to hamax;   $ clear bits in ha and xnl
      73          tracef ha(i) = fg; end do;
      74      do  i = 1 to nlptr;  $ clear flags for vars defined in this routin
      75      if  (mbdef mba(nlblk nl(i))) nltrac nl(i) = fg;
      76          end do;
      77      return;
      78 / l(7) / $ check store range of index assignments
      79      chinxfg = fg;
      80      chinxsfg = yes;  $ show statement occured
      81      dbgcspcp = 0;  $ clear exception stack
      82      do  i = 1 to hamax; chinxf ha(i) = fg; end do;
      83      do  i = 1 to nlptr;  $ clear flags for vars defined here
      84          if  (mbdef mba(nlblk nl(i))) nlchinx nl(i) = fg;
      85          end do;
      86      return;
      87 / l(8) /
      88 / l(4) / $ trace and no trace store with namelist
      89      nargs = arglist(argptr) + 1;
      90      argptr = argptr - nargs;
      91      do  i = 0 to nargs-1;  $ process args in turn
      92          hap = arglist(argptr+i);  $ get arg
      93          if  ep ha(hap) then  $ var. has been sized
      94              if  case > 6 then  chinxf ha(hap) = fg;
      95              else  tracef ha(hap) = fg; end if;
      96              ifaglob(xhax, hap);  $ see if global
      97              if  xhax then   $ is global
      98                  xnl = nlno xha(xhax);  $ point to -nl-
      99                  if  mbdef mba(nlblk nl(xnl)) then  $ defined here
     100                      if  case > 6 then  nlchinx nl(xnl) = fg;
     101                      else  nltrac nl(xnl) = fg;    end if;
     102                      end if;
     103                  end if;
     104          else  $ not sized, put in stack
     105              if  case > 6 then  $ 'check' case
     106                  do  j = 1 to dbgcspcp;  $ search stack
     107                      if  (dbgcspc(j) = 0 ! dbgcspc(j) = hap) quit do;
     108                      end do;
     109                  if  j > dbgcspcp then  $ not in stack
     110                      countup(dbgcspcp, dbgspcmax, 'dbgcspc');
     111                      end if;
     112                  dbgcspc(j) = hap;  $ set index
     113                  .f. j, 1, dbgcspcf = fg;  $ set flag value
     114              else
     115                  do  j = 1 to dbgtspcp;  $ search 'trace' stack
     116                      if  (dbgtspc(j) = 0 ! dbgtspc(j) = hap) quit do;
     117                      end do;
     118                  if  j > dbgtspcp then  $ not in stack
     119                      countup(dbgtspcp, dbgspcmax, 'dbgtspc');
     120                      end if;
     121                  dbgtspc(j) = hap;  $ set value
     122                  .f. j, 1, dbgtspcf = fg;  $ set flag value
     123                  end if;
     124              end if;
     125          end do;
     126
     127      end subr gentrace;
       1 .=member  gensert
       2      subr gensert(case);  $ process debug 'assert' statement.
       3      $   generator for the assert statement.
       4      size  i(ps);             $ do loop variable
       5      size  case(1);          $ case = 0 is initial, case = 1 is ender.
       6      size  newlab(ps);        $ label ha ptr generated
       7      size  nwds(ps);          $ nomber of words
       8      size  nhap(ps);   $ ha pointer of name sds
       9
      10      if  (case = 1) go to gencode;
      11      assertstp = 0;          $ ptr to assert stack
      12      if  (debuglevel = 2) assertfg = yes;  $ accumulate vars if full de
      13      return;
      14
      15 /gencode/          $ end of assert statement. ha ptrs have been
      16      $   collected in assertst.
      17      $   generate: if e go to lab; call printr; /lab/
      18      if  (debuglevel = no) return;  $ do nothing if no debugging wanted
      19      $   complile no code if assert argument is nonzero constant.
      20      pop(i);  $ get expression.
      21      if  hascon ha(i)  then  $ if constant expression.
      22          if  (conval(i))  return;  $ if nonzero constant.
      23          end if;
      24      push(i);  $ restore expression.
      25      labget(newlab)     push(newlab)
      26      call genifgo(op_if);
      27      if  debuglevel = 1 then  $ minimal assert facility wanted
      28          pushname(nhap, debugnames(dbg_asfl));  $ push name of simple r
      29          call gencall(call_noparms);  $ generate call
      30          labdef(newlab);  $ define label
      31          return;  $ done with this case
      32          end if;
      33
      34      pushname(nhap, debugnames(dbg_prhd)); $ print header routine
      35      endblock = no;  $ dont end a block
      36      pushint(proclineno);  $ parameter is line no.
      37      arglist(argptr) = 0;  $ one argument
      38      call gencall(call_parms);  $ call routine
      39      do  i = 1 to assertstp;  $ pass aar name, val, and size
      40          $   only accumulate names of variables, so ignore if not in ha
      41          if  (ep ha(assertst(i)) = 0)  cont do;
      42          if  (isafnct voa(ep ha(assertst(i))))  cont do;  $ if function
      43          if  (dimn voa(ep ha(assertst(i)))) cont do;  $ dont print arra
      44          nwds = (syze voa(ep ha(assertst(i))) - 1) / mws + 1;
      45          pushname(nhap, debugnames(dbg_prvr));  $ push name of routine
      46          endblock = no;   $ dont end block
      47          call sdsnamr(assertst(i)); $ get name
      48          call getxsds(nhap, sdsnamstr);  $ build constant
      49          push(nhap); pushint(nwds); push(assertst(i)); $ push parms
      50          arglist(argptr) = 2;  $ 3 parameters
      51          call gencall(call_parms);  $ generate call
      52          end do;
      53
      54      labdef(newlab)          $ define label
      55      assertfg = no;           $ end of assertion
      56
      57      end subr gensert;
       1 .=member  trflowr
       2      subr trflowr;
       3      $   debug trace routine for flow trace. checks trflowfg to see if
       4      $   the current routine should be traced.
       5      testdebug;  $ see if debug code wanted
       6      $   if so, it generates a call
       7      $   to print routine. the global -trflowrp- indicates which type
       8      $   of code block is being executed.
       9      $   (eg label, while, until, if, etc)
      10      size  dlab(ps);     $ debug label
      11      size  param(ws);    $ parameter to be passed to runtime routine
      12      size  i(ps);        $ do loop variable
      13      size  savelab(ps);
      14      size  newlab(ps);
      15      size  nhap(ps);  $ ha pointer of name
      16
      17      $   control flow for these types,  in addition to trace  calls
      18      $   fields of param
      19      +*  flowtyp   = .f. 01, 03, **  $ type
      20      +*  flowblock = .f. 04, 10, **  $ block no.
      21      +*  flowlino  = .f. 17, 16, **  $ line no.
      22
      23      if  trflowp = flowend  then   $ at a return statement - call
      24          $   ending print routine.
      25          pushname(nhap, debugnames(dbg_prfl));  $ set name
      26          endblock = no;  $ dont end block
      27          call gencall(call_noparms);  $ call routine
      28          return;
      29          end if;
      30
      31      $   assign values to run-time globals
      32      param = 0;
      33      flowtyp param = flowp trflowp;  $ type of code block
      34      if  flowp trflowp ^= flowiff then  $ for all cases except if-false
      35      $   gnerate a new identification number and store it in csa
      36          countup(flowgen, flowgenlim, 'flowgen');
      37          ifnum csa(csaptr) = flowgen;
      38          flowblock param = flowgen;
      39      else
      40          flowblock param = ifnum csa(csaptr);   $ get block number.
      41          end if;
      42
      43      flowlino param = proclineno;
      44      if  trflowp = flowifgt then  $ if go to (true)
      45      $   generate ifnot c go to newlab; call flowr  go to lab; /newlab/
      46          savelab = arglist(argptr - 1);
      47          labget(newlab)
      48          arglist(argptr - 1) = newlab;
      49          call genifgo(op_ifnot);
      50      else
      51      $   for if statements which do not have else parts, must generate
      52      $   an else part of form  go to dlab;/elab/ call trace;  /dlab/
      53      $   so that the number of times the condition is
      54      $   false may be counted.
      55      if  flowiftyp trflowp then
      56          labget(dlab) push(dlab)  call gengol(op_goto);
      57          if  trflowp = flowifsf then
      58              labdef(endlbl csa(csaptr));
      59          else
      60               labdef(bodylbl csa(csaptr))
      61               end if;
      62          end if;
      63      end if;
      64
      65      pushname(nhap, debugnames(dbg_trfl));  $ push name
      66      endblock = no;   $ dont end block
      67      pushint(param);  $ push parameter
      68      $   for label blocks, set debugtab(3) = label name
      69      if  trflowp = flowlab then
      70          call sdsnamr(trflowl);  $ get label name as sds
      71          call getxsds(nhap, sdsnamstr);  $ build constant
      72          push(nhap);  $ push it
      73          end if;
      74
      75      arglist(argptr) = (trflowp = flowlab);  $ set no. of parms
      76      call gencall(call_parms);  $ call routine
      77      if  trflowp = flowifgt then $ if go to - true
      78          $   emit...go to lab;  /savelab/
      79          push(savelab)     call gengol(op_goto);
      80          labdef(newlab)    return;
      81          end if;
      82
      83      if  flowiftyp trflowp then labdef(dlab)  end if;
      84
      85      end subr trflowr;
       1 .=member  trstorr
       2      subr trstorr(target);
       3      $   generates call to prstorer for debugging trace of variable
       4      $   stores.  it is assumed that the top entry in the voa is an
       5      $   assignment.  first the ha entry of the variable is examined
       6      $   to see if the variable should be traced.
       7      $   the value of trstorp indicates the type of the assignment.
       8      size  param(ws);         $ parameter passed to run time routine
       9      size  nwds(ps);          $ number of words of target
      10      size  nwdsp(ps);         $ voa ptr to either in1 or in2
      11      size  target(ps);        $ ha ptr to target variable
      12      size  nhap(ps);  $ ha pointer for name
      13      size  nparms(ps);  $ number of params to debug call
rbkn  10      size  nparmv(ps);  dims nparmv(6);  $ number of parameters.
rbkn  11      data  nparmv = 3, 5, 5, 5, 4, 3;  $ values.
      16
      17      $   fields of param
      18      +*  vsize = .f. 1, 8, **          $ size of target (in words)
      19      +*  vlino = .f. 17, 16, **         $ line number of assignment
      20      +*  vopcod = .f. 9, 3, **         $ type of store
      21      +*  vindx = .f. 12, 1, **          $ flag indicating indexed store
      22
      23      testdebug;  $ see if debug code wanted
      24      param = 0;
      25      if  syze voa(inp1 voa(voptr-1)) > syze voa(inp2 voa(voptr-1)) then
      26          $ determine which is larger, source or target, size passed
      27          $ to run-time routine is the smaller of the two.
      28          nwdsp = inp2 voa(voptr-1);  $ source
      29      else
      30          nwdsp = inp1 voa(voptr-1);  $ target
      31          end if;
      32
      33      nwds = (syze voa(nwdsp)-1)/mws+1; $ set size in words
      34      vsize param = nwds;   $ size of target
      35      vlino param = proclineno;
      36      vopcod param = trstorp;           $ type of assignment
      37      vindx param = trstori;            $ indexed flag
      38      nparms = nparmv(trstorp) + trstori;  $ number of parms.
      39      pushname(nhap, debugnames(dbg_prst+nparms-3));  $ push routine nam
      40      endblock = no;  $ dont end block
      41      call sdsnamr(target);   $ get sds for name of variable
      42      call getxsds(nhap, sdsnamstr);   $ build constant
      43      push(nhap);  $ push name
      44      pushint(param);  $ push parameter
      45      push(trstor1);   $ push value
      46      if  trstori then  $ indexed assignment
      47          push(trstor2); $ push index
      48          end if;
      49
      50      if  trstorp > 1 & trstorp < 5 then  $ field assignment
      51          if  trstori then
      52              push(trstor5);  push(trstor4);
      53          else
      54              push(trstor4);  push(trstor3);  $ field pos and length
      55              end if;
      56
      57      elseif  trstorp = 5 then  $ .ch. assignment
      58          push(trstors);  $ push position
      59          end if;
      60
      61      arglist(argptr) = nparms-1;  $ set no. of parameters
      62      call gencall(call_parms);  $ generate call
      63
      64      end subr trstorr;
       1 .=member  chinxr
       2      subr chinxr(target, indexvar);
       3      $   generates call to indexr to check range of indexed store.
       4      $   the global oarameter chinxrp contains the voaptr to
       5      $   indexed store operation.
       6      size  target(ps);   $ ha ptr to target of store
       7      size  indexvar(ps);  $ ha pointer for index.
       8
       9      size  nhap(ps);  $ ha pointer for name
      10      testdebug;  $ check if debug statements wanted
      11      $   check index range
      12      if  (arb voa(ep ha(target))) return;  $ dont checks arg arrays
      13      pushname(nhap, debugnames(dbg_cinx));  $ push routine name
      14      endblock = no;  $ dont end block
      15      call sdsnamr(target); $ get var name as sds
      16      call getxsds(nhap, sdsnamstr);  $ build constant
      17      push(nhap);  $ push name
      18      push(indexvar);  $ push index
      19      pushint(dimn voa(ep ha(target)));  $ push dimension
      20      pushint(proclineno);   $ push line no.
      21      arglist(argptr) = 3;  $ 4 parameters.
      22      call gencall(call_parms);  $ generate call
      23
      24      end subr chinxr;
       1 .=member  trentrr
       2      subr trentrr;
       3      $   checks status of trentr flag and generates call to off-line
       4      $   trace routine accordingly.
       5      size  i(ps);             $ do loop variable
       6      size  nwds(ps);          $ number of words
       7      size  nhap(ps);  $ ha pointer of name
       8
       9      testdebug;  $ see if debug statements wanted
      10      if  trentrp = entrrout  then   $ entry subr case
      11          pushname(nhap, debugnames(dbg_pren)); $ push oroutine name
      12          endblock = no;  $ dont end block
      13          call gencall(call_noparms);  $ generate call to it
      14          return;
      15          end if;
      16
      17      if  trentrp = entrend  then  $ exit function case
      18          pushname(nhap, debugnames(dbg_prex));  $ push routine name
      19          endblock = no;  $ dont end block
      20          pushint(proclineno);  $ push line number
      21          if  fswitch then  $ see if function
      22              pushint(((syze voa(voafnct))-1)/mws+1); $ push no. of word
      23              push(naym voa(voafnct));  $ push function value
      24              end if;
      25
      26          arglist(argptr) = fswitch*2;  $ set no. of parms
      27          call gencall(call_parms);  $ call debug routine
      28          return;
      29          end if;
      30
      31      $   argument case.  hap is biased by 2
      32      pushname(nhap, debugnames(dbg_prar));  $ push routine name
      33      endblock = no;  $ dont end block
      34      call sdsnamr(trentrp-2);  $ get sds for name of arg
      35      call getxsds(nhap, sdsnamstr);   $ build constant
      36      push(nhap);  $ push it
      37      pushint(((syze voa(ep ha(trentrp-2)))-1)/mws+1); $ push no. words
      38      push(trentrp-2);  $ push value
      39      arglist(argptr) = 2;  $ 3 parameters
      40      call gencall(call_parms);  $ generate call to debug routine
      41
      42      end subr trentrr;
       1 .=member  tabdump
       2      subr tabdump(lo,hi,ifall); $ dump selected tables.
       3      $   give symbolic dump of selected tables.  list voa entires lo
       4      $   through all.  the parameter -ifall- will eventually be used
       5      $   to give selective dump.
       6      size  lo(ps), hi(ps), ifall(ps);
       7
       8      if  ifall then
       9          call voadump(lo, hi);
      10          call xargdump;
      11          call dumpaq('val', val, 1, valptr-1);
      12          call hadump;
      13          call xhadump;
      14          call nldump(1, nlptr);
      15          call mbadump;
      16          call csadump(1, csaptr);
      17      else  $ short dump
      18          call voadump(lo, hi);
      19          call xargdump;
      20          call csadump(1, csaptr);
      21          end if;
      22
      23      end subr tabdump;
       1 .=member  nldump
       2      subr nldump(lo, hi);  $ dump names list  nl
       3      size  lo(ps), hi(ps);  $ lo and high indices to dump
       4      size  i(ps);            $ do loop index
       5      size  nlwd(nlsz);  $ copy of nl entry being dumped
       6      size  lines(ps);  $ number of lines for dump
       7      size  l(ps);  $ index of line being printed
       8      size  lp(ps);  $ position in current line
       9      +*  lablabel =
      10'    i size dimn  madr mblk  xha chnx trac amod name ==nl== '**
      11      endl  textl(' dump of global names list - nl'); endl
      12      $   we write two entries per line
      13      lines = (hi - lo + 2)/2;  $ number of lines to print
      14      do  l = 1 to lines;
      15          if  (l - 20*(l/20))=1 then
      16              endl textl(lablabel)  tabl(60) textl(lablabel) endl
      17              end if;
      18          i = l + lo - 1;
      19          while i<=hi;
      20              intl(i);
      21              nlwd = nl(i);  $ word to dump
      22              intl((nlsize nlwd))
      23              intl((nldimn nlwd))
      24              intlp((nlmadr nlwd), 6)
      25              intl((nlblk nlwd))
      26              intl((nlha nlwd))
      27              intl((nlchinx nlwd))
      28              intl((nltrac nlwd))
      29              intl((nlamode nlwd))
      30              skipl(1)
      31              call xsdsnamr(nlha nlwd);  textl(sdsnamstr)
      32              i = i + lines;
      33              getlpos(lp); $ get positio
      34              if  lp<60  then  tabl(60);  end if;
      35              end while;
      36          endl
      37          end do;
      38      endl
      39
      40      end subr nldump;  $  end - nldump
       1 .=member  hadump
       2      subr hadump;  $ list contents of ha
       3      size  i(ps);  $ index
       4      size  l(ps);  $ line being printed
       5      +*  hatitle =
       6'    i   ep  var scon labn trcf chnx lbin char name  = ha ='**
       7      size  lines(ps);  $ number of lines to list
       8      size  h(hasz);  $ entry being dumped
       9      size  lp(ps);  $ position in line
      10      size  atright(1);  $ on when just listed entry at right of page
      11
      12      endl
      13      textl('   ha contents')  endl
      14      atright = yes;
      15      lines = 0;
      16      do  i = 1 to hamax;
      17          h = ha(i);
      18          if  (hainuse h = 0) cont do;  $ ignore if not used
      19          if  atright  then
      20              endl;
      21
      22              lines = lines + 1;
      23              if  (lines - 20*(lines/20))=1 then  $ list label
      24                  endl textl(hatitle)  tabl(60) textl(hatitle) endl
      25                  end if;
      26              atright = no;
      27          else
      28              tabl(60);  $ advance for right entry
      29              atright = yes;  $ indicate that now at right
      30              end if;
      31
      32          intl(i)
      33          intl((ep h))
      34          intl((var h))
      35          intl((hascon h))
      36          intl((labno h))
      37          intl((tracef h))
      38          intl((chinxf h))
      39          intl((namintern h))
      40          intl((nchars h))
      41          if  (var h) ! (labno h)  then $ if name or label, list name
      42              until yes;  $ quit if should not list name.
      43                  if  ep h then  $ if this is in -voa-.
      44                      if  (const voa(ep h)) quit until;   $ no name if c
      45                      end if;
      46
      47                  skipl(1)  naml(i)
      48                  end until;
      49              end if;
      50          end do;
      51      endl
      52
      53      end subr hadump;
       1 .=member  voadump
       2      subr voadump(lo, hi);  $ list voa contents.
       3      $   this routine generates a symbolic dump of the voa from
       4      $   locations -lo- through -hi-.
       5      $   the -ha-, -xha-, and -nl- are also dumped.
       6
       7      size  lo(ps);  $ starting location for dump
       8      size  hi(ps);  $ 1 + last index to list.
       9      size  hap(ps);  $ ha index if in ha.
      10      size  i(ps);  $ voa index
      11      size  l(ps);  $ line number during xarg dump
      12      size  v(voasz);  $ voa entry being dumped
      13      size  tlines(ps);  $ number of lines since title last listed.
      14      size  opcodeval(ps);  $ value of opcode
      15      size  naymval(ps);  $ value of naym field
      16      size  vlenval(ps);  $ value of vlen
      17      size  vbegval(ps);  $ value of vbeg
      18      +* optitle =
      19'    i opcd       syze  oup inp1 inp2 inp3   db luse abeg alen dflv kb a
      20m eb ch naym'**
      21      +*  vartitle =
      22'    i syze dimn const temb type  madr mblk  arg argn lxty sign vbeg vle
      23n dflv kb am xf nuse naym'**
      24      size  oplab(sds(5)); dims oplab(nopcodes);
      25      data  oplab =
      26      '    +', '    -', '   gt', '   lt','   ge',  $ 1-5
      27      '   le', '   eq', '   ne', '    *', '    /',  $  6-10
      28      '   or', '.seq.', '  and', ' exor', '.sne.',  $ 11-15
      29      ' .nb.', ' .fb.', '.not.', 'fcall', 'scall',  $ 16-20
      30      '  a=b', ' data', ' f x=', '   io', '  ret',  $ 21-25
      31      ' =.f.', '   if', 'label', ' goto', ' goby',  $ 26-30
      32      '=a(i)', 'a(i)=', 'f a(=', 'ifnot', ' .cc.',  $ 31-35
      33      ' .in.', '= .e.', '= .s.', ' e x=', '.s.x=',  $ 36-40
      34      'e.a(=', 's.a(=', 'rl  +', 'rl  -', 'rl gt',  $ 41-45
      35      'rl lt', 'rl ge', 'rl le', 'rl eq', 'rl ne',  $ 46-50
      36      'rl  *', 'rl  /', 'rl  -', 'float', ' ifix',  $ 51-55
      37      '  abs', ' iabs', ' aint', '  int', ' amod',  $ 56-60
      38      '  mod', ' sign', 'isign', '  dim', ' idim', $ 61-65
      39      '  exp', ' alog', 'alg10', '  sin', '  cos',  $ 66-70
      40       ' tanh', ' sqrt', ' atan', 'atan2', ' list',  $ 71-75
      41      '.pad.';                             $ 76
      42
      43      endl  textl(' voa dump from ') intl(lo) textl(' to ') intl(hi-1)
      44      endl endl endl
      45
      46      $   list variables first
      47      textl('  variables, temporaries, constants (opb=no)'); endl;
      48      tlines = 0;
      49      do  i = lo to hi-1;
      50          v = voa(i);
      51          if  (opb v = yes) cont do;  $ ignore operations
      52          tlines=tlines + 1;
      53          if  (tlines - 20*(tlines/20)) = 1  then
      54              endl  textl(vartitle)  endl
      55              end if;
      56          intl(i)
      57          intl((syze v))
      58          intl((dimn v))
      59          intlp((const v), 6)
      60          intl((temb v))
      61          intl((type v))
      62          intlp((madr v), 6)
      63          intl((mblk v))
      64          intl((arb v))
      65          intl((argno v))
      66          intl((lextype v))
      67          intl((signbit v))
      68          vbegval = vbeg v;
      69          intl(vbegval)
      70          vlenval = vlen v;
      71          intl(vlenval)
      72          intl((deflev v))
      73          intlp((keeb v), 3)
      74          naymval = naym v;
      75          intlp((amode v), 3)
      76          intlp((isafnct v), 3)
      77          intlp((varnuse v), 5)
      78          intl(naymval)
      79          skipl(2)
      80      $   if variable, print name
      81      $   if string constant, print first word of constant in display
      82      $   if non-string constant, print first word in octal
      83      $   if temporary, print 'temporary'
      84      $   if subroutine or function, print first word of name
      85      if  temb v then  textl(' temporary')
      86      elseif  const v then
      87              if  lextype v = rztok ! lextype v = sstok !
      88                  lextype v = strtok
      89                  then  wordl(val(vbegval));
      90                  else
      91                      if  signbit v then charl(1r-); end if; $ note
      92      $   folded constants, negative result
      93                      call octlr(val(vbegval));
      94                      if  syze v < 17 then $ if small,  print integer
      95                          skipl(2) intl(val(vbegval)); end if;
      96                          end if;
      97          else  $ not constant, print first word of name
      98              naml(naymval); end if;
      99          endl
     100          end do;
     101
     102      setlpos(1); charl(1r1)  endl; $ page eject
     103
     104      textl('   operations (opb=yes)'); endl
     105      tlines = 0;
     106      do  i = lo to hi-1;
     107          v = voa(i);
     108          if  (opb v = no) cont do;
     109          tlines = tlines + 1;
     110          if  (tlines -20*(tlines/20)) = 1  then
     111              endl  textl(optitle)  endl end if;
     112
     113          intl(i)
     114          opcodeval = opcode v;
     115          intl(opcodeval)
     116          skipl(1)
     117          textl(( oplab(opcode v)) )
     118          intl((syze v))
     119          intl((oup v))
     120          intl((inp1 v))
     121          intl((inp2 v))
     122          intl((inp3 v))
     123          intl( (dboup v)*1000 +(db1 v)*100 + (db2 v)*10 + (db3 v)  )
     124          intl((lastuse v))
     125          intl((argbeg v))
     126          intl((arglen v))
     127          intl((deflev v))
     128          intlp((keeb v), 3)
     129          intlp((amode v), 3)
     130          intlp((seblk v), 3)
     131          intlp((bytaln v), 3)
     132          naymval = naym v;
     133          intl(naymval)
     134          skipl(2)
     135      $   if -data- statement, print name of target
     136      $   if -call-, print name of called routine
     137          if  opcodeval=op_call  then  textl('call ')  end if;
     138          if  opcodeval = op_data ! opcodeval=op_fcall
     139              ! opcodeval=op_call   then
     140              naml(naymval);
     141              end if;
     142
     143          if  blkendtype(opcodeval)>=7 & blkendtype(opcodeval)<=10 then
     144              naml(naym voa(inp1 v));
     145              textl(' =')  end if;
     146
     147
     148      $   if label, list name enclosed in /.
     149          if  opcodeval=op_lab  then
     150              charl(1r/) naml(naymval) charl(1r/)
     151              end if;
     152
     153          endl
     154          end do;
     155
     156      end subr voadump;
       1 .=member  xargdump
       2      subr xargdump;  $ dump xarg.
       3      size  i(ps), l(ps);  $ loop indices.
       4      size  tlines(ps);  $ number of lines.
       5
       6      $   list xarg contents, 5 elements per line.
       7      skipl(20) textl('xarg contents') endl
       8      textl('    i  rep d  voa')  endl
       9      if  (xargptr<=1)  return;
      10      tlines = (xargptr+4)/5; $ number of lines
      11      do  l = 1 to tlines;
      12          i = l;
      13          while  i  < xargptr;
      14              if  i^=l  then  skipl(5) end if;
      15                  intl(i) charl(1r.)
      16                  intlp(xarg_rep xarg(i), 4) intlp(xarg_db xarg(i), 2)
      17              intl(xarg_voa xarg(i))
      18              i = i + tlines;
      19              end while;
      20          endl
      21          end do;
      22      endl
      23
      24      end subr xargdump;
       1 .=member  mbadump
       2      subr mbadump;  $ list contents of mba.
       3      size  i(ps); $ loop index.
       4      size  hap(ps);  $ ha index for nameset entry.
       5      if  mbaptr  then  $ list mba contents.
       6          endl  textl('contents of machine block array (mba).') endl
       7          textl('    i used  def chain lengh  xha   ha name') endl
       8          do  i = 1 to mbaptr;
       9              intl(i)  intl(mbused mba(i))
      10          intl(mbdef mba(i)) intlp(mbchain mba(i), 6)
      11          intlp(mblen mba(i), 6) intl(mbxha mba(i))
      12              hap = mbha mba(i);  intl(hap)
      13              if  hap  then $ if in ha, give name
      14                  skipl(1) naml(hap)  end if;
      15              endl
      16              end do;
      17          endl
      18          end if;
      19
      20      return;
      21      end subr mbadump;
       1 .=member  xhadump
       2      subr xhadump;  $ list contents of xha
       3      size  i(ps);  $ index
       4      size  l(ps);  $ line being printed
       5      +*  xhatitle =
       6'    i nlno link  mba  bif char name  == xha =='**
       7      size  lines(ps);  $ number of lines to list
       8      size  h(xhasz);  $ entry being dumped
       9      size  lp(ps);  $ position in line
      10      size  atright(1);  $ on when just listed entry at right of page
      11
      12      endl textl('  xha contents')  endl
      13      atright = yes;
      14      lines = 0;
      15      do  i = 1 to xhamax;
      16          h = xha(i);
      17          if  (h=0)  cont do; $ ignore zero entries
      18
      19          if  atright  then
      20              lines = lines + 1;  endl
      21              if  (lines - 20*(lines/20))=1 then  $ list label
      22                  endl textl(xhatitle)  tabl(60) textl(xhatitle) endl
      23                  end if;
      24              atright = no;
      25          else
      26              tabl(60);  $ advance for right entry
      27              atright = yes;  $ indicate that now at right
      28              end if;
      29
      30          intl(i)
      31          intl((nlno h))
      32          intl((xlink h))
      33          intl((xnsblk h))
      34          intl((xhabif h))  $ builtin function index
      35          intl((xnchars h))
      36          skipl(1)  call xsdsnamr(i);  textl(sdsnamstr)
      37          end do;
      38      endl endl
      39
      40      end subr xhadump;
       1 .=member  csadump
       2      subr csadump(clow, chi);  $ list contents of -csa-
       3      $   dump of compound statement array routine
       4      size  clow(ps);   $ low index of array
       5      size  chi(ps);   $ hi index
       6      size  i(ps);   $ do loop variable
       7      size  csam(csasz);   $ csa entry
       8      size  types(sds(7));  dims types(cstypes);  $ names of cs types
       9      data
      10          types(cstype_subr) = 'sub': types(cstype_fnct) = 'fnct':
      11          types(cstype_while)= 'whil': types(cstype_until) = 'untl':
      12          types(cstype_if) = 'if': types(cstype_do) = 'do':
      13          types(cstype_prog) = 'prog':types(cstype_nameset) = 'nameset';
      14
      15
      16      textl('    ')   endl
      17      textl('    c o s a   d u m p')   endl
      18      textl('     typ         tlbl blbl elbl dolo dohi  inc  var sign')
      19      textl(' iftyp')   endl
      20      do  i =  clow to  chi;
      21          csam = csa(i);   $ elemt of stack
      22          intl(i)  textl(types(cstype csam))  tabl(15)
      23          intl(testlbl csam)  intl(bodylbl csam)  intl(endlbl csam)
      24          intl(dolop csam)  intl(dohip csam) intl(doincp csam)
      25          intl(dovarp csam) intl(dosignp csam)
      26          intl(csiftype csam)   endl
      27          end do;
      28
      29      end subr csadump;
       1 .=member  arastar
       2      subr arastar(lib,max,tot,rout);     $compute usage of arrays
       3      size  lib(ws+1);      $ array name
       4      size  max(ps);          $ max no of words in array
       5      size  tot(ps);          $ no of words used
       6      size  rout(ws+1);    $ routine in which max usage occurred
       7      textl(lib)  tabl(15) intl(max)
       8      skipl(5)  intl(tot)  skipl(5) textl(rout)
       9      tabl(45) intl(max-tot)  endl
      10      totwaste = totwaste + (max-tot);
      11      return;
      12      end subr arastar;
       1 .=member  genexit
       2      subr genexit;  $ generator phase exit routine
       3      $   the gen part of compiler is to exit through this routine
       4      $   if global -exitcode- is non-zero, abnormal end is indicated,
       5      $   0 indicates normal exit.
       6      $   this routine collects compilation statistics, signs off, etc.
       7
       8      size  i(ps);            $ do loop index
       9      size  xhaused(ps);      $ no of words in xha occupied
ldsb  30      size  termcode(ws);     $ termination code.
      10
      12      textl(' ') endl  $ blank line
      13      $   first we check that parsing has terminated after end
      14      $   of routine, issuing diagnostic otherwise
      15      if  voptr ^=  voafnct then $ non-standard end
ldsc  13          terml(yes);  $ this will go to terminal output
      16          nerrors = nerrors+1; $ indicate error
      17          call lstlin;  $ list input line.
mgfc  25 .+s10    error_s10;  $ give s10 error character.
      18          textl(error_notice) textl('not terminating at end of routine')
      19          endl
ldsc  14          terml(no);   $ end of terminal output
      20          end if;
      22
      23      call clossio(tokenfile, iorc);
      24
      25      if  crossrefoption  then  $ complete reference file.
      26          crefput(0);         $ indicate end of file.
      27          if  crbuffptr  then $ flush buffer if has data.
      28          call wtrwsio(crfile, iorc, crbuff, 1, crbuffmax);
      29              end if;
      30          $  if proc directory wanted, generate it.
      31          if  proclist  then  $ if producing directory,
      32              call rewisio(crfile, iorc, access_read);
      33              call pdsort;    $ produce directory.
      34              end if;
      35          call clossio(crfile, iorc);
      36          end if;
      37
      38      if  (lcs_opt=0)  go to endofstat; $ if no want statistics.
      39      call stitlr(1, 'statistics for this parse.');
      40      ejectlp(20);   $ put statistics listing on new page if wont fit
      41
      42      textl('little parse statistics.') endl
      43      textl(' array         max      used   procedure  unused') endl
      44      +*  arastat(nam,max,tot,rout) =
      45          call arastar(nam, max, tot, rout); **
      46
      47      arastat('ha'      ,hamax         ,loadha        ,loadrha  );
      48      arastat('names'   ,namesmax      ,loadnames     ,loadrnames );
      49      arastat('nl'      ,nlmax         ,nlptr         , ' '    );
      50      arastat('tlist'   ,tlistmax      ,loadtlist     ,loadrtlist);
      51      arastat('val'     ,valmax        ,loadval       ,loadrval  );
      52      arastat('voa'     ,vomax*2       ,loadvoa*2      ,loadrvoa );
      53      arastat('xarg'    ,xargmax       ,loadxarg      ,loadrxarg );
      54
      55      xhaused = 0;  $ reset used count for xha
      56      do  i =  1 to  xhamax;
      57          if  (xnameptr xha(i) = 0) cont do; $ ignore if empty
      58          xhaused = xhaused + 1;  $ update used count
      59          end do;
      60
      61      arastat('xha'     ,xhamax        ,xhaused       ,' '   );
      62      arastat('xnames'  ,xnamesmax     ,xnamesptr     ,' '   );
      63
      64      textl(' ') endl
      65      textl('unused memory words ') intl(totwaste) endl endl endl
      66 .+haprobes.
      67      tintl('number of times blkend reset deflev ',blkendreset);endl
      68      tintl('number of times emass reset deflev',emassreset);
      69      tintl('ha examined ', tothaprobes) textl(' times ') endl
      70      tintl('ha entries examined ', tothaexam) endl
      71 ..haprobes
      72 .+ifconstat.
      73      if  ifcontot  then  $ report on constant ifs found
      74          textl('found') intl(ifcontot)
      75          textl(' if''s with constant inputs.') intl(ifcongotos)
      76          textl(' changed to goto''s.') endl
      77          end if;
      78 ..ifconstat
      79 .+ncfstat.
      80      if  ncftot then  $ if any negative constants folded
      81          tintl('total number of negative constants', ncftot) endl
      82          end if;
      83 ..ncfstat
      84
      85 /endofstat/  $ here when statistics listed.
      86
      87      terml(yes);  $ this goes to terminal
      88      if  nerrors  then
      89          intl(nerrors) textl(' errors detected.') endl
      92          end if;
      93
ldsa 115 .+rep.
ldsa 116      if  rep_opt  then  $ if reporting, close report file.
ldsa 117          file repfile access = release;
ldsa 118          end if;
ldsa 119 ..rep
      94      terml(no);   $ end of terminal listing
ldsb  31
ldsb  32
ldsb  33 $    determine termination code.
ldsb  34
ldsb  35      termcode = 0;
ldsb  36      if  (nwarnings)  termcode = 4;
ldsb  37      if  (nerrors)  termcode = 8;
ldsb  38
      95      if  voawrt then  $ if writing voa file
      96          vof = 0;  $ clear frame
      97          vof_code vof = voaeof_code; $ indicate end of file
      98          vofhdrseq = vofhdrseq+1;  vof_hdrseq vof = vofhdrseq;
      99          write voafile, vof;
     100          file  voafile access = release;
     101      else
     102          terml(yes);  $ write this to terminal file
     103          endl textl('end of compilation - not writing voa file') endl
     104          terml(no); call clsterm;
ldsb  39          call ltlfin(0, termcode);
     106          end if;
     107
     108      if  exitcode then  $ if quit due to error, abort
     109          call lstlin;  $ list input line.
     110          terml(yes);  $ output this to terminal
mgfc  26 .+s10    error_s10;  $ give s10 error character.
     111          textl(error_notice)
     112          textl(' abnormal termination due to previous error') endl
     113          textl('procedure ') textl(currsubrname)  endl
     114          call clsterm;  $ close terminal output file
     115          call ltlfin(1,1); $ and abort job
     116          end if;
     117
     118      terml(no); call clsterm;  $ close terminal file
ldsb  40          call ltlterm(2, termcode);
     120
     121      end subr genexit;
     122      $   this concludes the gen phase of the little compiler.
     123      $       (just wait until we write a big compiler.)

« 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: