Personal tools
You are here: Home Projects SETL LITTLE Source code LEX: Lexical scan phase.
Document Actions

LEX: Lexical scan phase.

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

LEX: Lexical scan 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 first phase of the little compiler.  it performs
      45 $    the lexical scan, and is known as 'lex'.
      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 $    the following is a list of the routines in the scanner -
      53
      54
      55 $
      56 $ name          description
      57 $ ---------------------------------------------------------------   c
      58 $ start         contains size statements for global variables
      59 $ lexini        initialisation routine
      60 $ setlit        define literal strings.
      61 $ inslit        insert literals in hash table.
      62 $ lexdo         driver for scanner
      63 $ nextw         top scanner routine, emits tokens to parser
      64 $ dfabsrb       absorbs macro definitions
      65 $ mcexpnd       expands macros
      66 $ trulex        builds tokens from input characters
      67 $ charinr       adds character to token
      68 $ givecr        gets next card from input stream
      69 $ hash          adds token to symbol table (ha)
      70 $ fivdec        converts integer to 5 right adjusted characters
      71 $ ibigr         compare symbols for cross-ref.
      72 $ detect        detects suspicious variables
      73 $ pflshr        control routine for puncher
      74 $ pncr          punches out token
      75 $ ermsg         lists error messages
      76 $ ertlist       list recent tokens if error detected
      77 $ toklr         list characters in token.
      78 $ ltoflo        report table overflow.
      79 $ lexexit       exit routine for scanner
      80
      81
      82 $    m a c r o   g l o s s a r y .
      83 $
      84 $    alphabetic (c)  =  1 if c is alphabetic character, else 0
      85 $    astkget (l)  = astk(l)  (astk is packed array)
      86 $    astklim  =  length of macro argumet stack astk
      87 $    astkput (v)  =  add v as new top of astk  (astk is packed)
      88 $    astkset (l,c)  =  astk(l)=v;  (astk is packed array)
      89 $    bintok  =  code for binary token, e.g., '100b'
      90 $    buildz (h,n,t)  = build token with index n. t is type. h ha-index
      91 $    cab  =  ha-field for conditional assembly bit
      92 $    charin (c)  =  add c to current token  (cf. trulex)
      93 $    charl (c)  =  print character c
      94 $    countup (i,l,m)  =  add 1 to i; quit if exceeds l. m is message
      95 $    cpstr - characters in short token record
      96 $    cpw  =  characters per word
      97 $    cs  =  character size in bits
      98 $    dectok  =  code for integer token, e.g., '100'
      99 $    endl  =  end current print line, start new one
     100 $    ertoksave (h)  =  add ha-index h to lisf t orecent tokens seen
     101 $    geter (a,l)  =  return a(l)  (a is packed array)
     102 $    getfromkeep(char) = get character from buffer
     103 $    getrefsym (s,w)  = get sds string for token, w is cross ref wd.
     104 $    getsym (s,h)  =  get sds string for token with ha-index h
     105 $    givec (c)  = get next character from input, put in c
     106 $    givecstr (c) = get next character, when inside string
     107 $    hamax  =  dims of hash table, or ha.  (must be prime)
     108 $    hashin (i)  =  add token to ha, set i to ha-index
     109 $    hashtokorg  =  origin for sds input string hashtok used in hash
     110 $    hasz  =  size of ha-entry in bits
     111 $    icdsig = card marking card image record on token file
     112 $    intl (i)  =  print integer i in five columns
     114 $    intlp(n,c) = output integer in c columns
     115 $    iscachar (c)  =  1 if c is one of '. + -' (conditional asm.)
     116 $    isublim  =  max. no. of routines for cross-reference
     117 $    isymc (h,i)  =  i-th character of token with ha-index h
     118 $    keepc(char) = character backup macro, limit is keeplimit
     119 $    lettercode (c) = ordinal of c if alphabetic, else 0. a=1,b=2,etc.
     120 $    leldefault = default lexical error limit.
     121 $    lexlen  =  ha-field giving token length in characters
     122 $    lextyp  =  ha-field giving lexical type
     123 $    namesmax  =  dims of 'names' array; max. no. of words for name str
     124 $    listarglim  =  dims of listarg in nextw, same as max. macro args
     125 $    macdef (t)  =  auxiliary for defining macros in macros
     126 $    macdrop (m)  =  drop macro with ha-index m
     127 $    macorg  =  ha-field giving mtab index of macro def. (0 if not macr
     128 $    macstate - ha field, 'is name currently a macro'
     129 $    mactlim  =  max. no. of entries for macro def table mtab
     130 $    maxtoklen  =  max. length of token in characters
     131 $    maxlinesz  =  number of characters in output line
     132 $    mccd = last column of input card that scanner processes
     133 $    mflshr (h)  =  punch out token with ha-index h
     134 $    mstklim  =  max. no entries in mstk for macro expansion
     135 $    mtset (l,w)  =  set l-th entry of mtab to w (mtab is packed)
     136 $    mtabsize  =  size in bits of macro def table entry
     137 $    mtlim - max. no. of entries in macro definition table
     138 $    nameptr  =  ha-field giving index in 'names' of name of token
     139 $    nametok  =  code for name-type token, e.g., 'little'
     140 $    namptrb  =  length of nameptr field
     141 $    nchars  =  no. of characters in system character set
     142 $    no  =  1 (used for readability)
     143 $    numbugtoks  =  no. of lexical debugging tokens (cf. trulex)
     144 $    nuses  =  ha-field giving number of times token used
     145 $    octaltok  =  code for octal-type token, e.g. '100b'
     146 $    octl (w)  =  print word in octal form
     147 $    optok  =  code for period delimiter operator token, eg., '.and.'
     148 $    ps  =  pointer size in bits (maximum subscript value)
     149 $    ms  =  size of macro definition item
     150 $    q3 (a,b,c)  =  auxiliary for defining macros inside macros
     151 $    readbio (t,a,n)  =  binary read n words into array a from tape t
     152 $    readio (t,a,n)  =  coded read n words into array a from tape t
     153 $    reslim  =  max. no of tokens in nextw backup buffer
     154 $    rztok  =  code for right alinng, zero-fill token, e.g., 4rabcd.
     155 $    sds (n)  =  size need for sds string of n characters
     156 $    sdspack (a,n)  = add n characters as start of current token
     157 $    sdstl  =  size in bits needed to hold 20 chars of token in sds foo
     158 $    sdstok  =  code for self-defining-string token, e.g. ' 'string' '.
     159 $    seter (a,v,w)  =  set a(w) = v  (a is packed array)
     160 $    skipl (n)  =  skip forward n spaces on print line
     161 $    slen  =  length (in characters) field of self-defining-string
     162 $    sorg  =  origin field for self-defining-string
     163 $    spectok  =  code for special-type token, e.g., '('
     164 $    stringtok  =  generic code for string type token
     165 $    suspi  =  level of usage below which variable becomes suspicious
     166 $    tabl (n)  =  tab print file to column n
     167 $    textl (s)  =  print string s
     168 $    tintl (s,i)  =  print label s, then integer i
     169 $    tokch (p,c)  = set p-th char of hash input to char. c
     170 $    tokl (h)  =  print token with ha-index h
     171 $    tokout (hdr, ara, lo)  add hdr, ara(1)...ara(lo) to token file
     172 $    tokout1 (w)  =  add word w to token fiel buffer
     173 $    tokpack (pak,unp,n)  =  pac n chars of ara unp into array pak
     174 $    tokrbuflim  =  no. of entries in token buffer tokrbuf
     175 $    tokrcard  =  code for card-image record in token file
     176 $    tokreof  =  code for end-file record on token flei
     177 $    tokrtyp  =  field in token record giving lexical type
     178 $    tokrval  =  field in token record giving first few chars of token
     179 $    torklen  =  field in token record giving token length in chars.
     180 $    ws  =  word size in bits
     181 $    yes  =  1 (used for readability)
     182 $
       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 mods
       2 $    all changes are to insert self-description at -- mods.2 --
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
ldsa   1
ldsa   2 $    ldsa      d. shields          20-nov-81           level 81324
ldsa   3 $
ldsa   4 $    increase ha dimension yet again. for s32 unix, it is great help
ldsa   5 $    to be able to compile stlcod by appending text needed from stllib.
ldsa   6 $    this required change in cross-reference fields, so ref needs
ldsa   7 $    updating also.
ldsa   8 $    deck affected - macros
ldsa   9
hab    1
hab    2 $    hab       d. shields          01-oct-81           level 81274
hab    3 $
hab    4 $    increase ha dimension so can do full compilation of setl lib v21.
hab    5 $    new value (3929) cannot be increased without redoing table
hab    6 $    layouts due to field sizes of 12 bits.
hab    7 $    deck affected - macros
hab    8
dsz    1
dsz    2 $    dsz       d. shields          21-sep-81           level 81264
dsz    3 $
dsz    4 $    1.  make default for suspicious variables list 'susp=0/0' so
dsz    5 $        this list generated only if 'susp=1' specified.
dsz    6 $    2.  do not include 'name with prior usage being designated as
dsz    7 $        macro' warnings in warning count.
dsz    8 $    3.  add error message text for a case where '**' missing.
dsz    9 $    decks affected - lexini, ermsg
dsz   10
dsy    1
dsy    2 $    dsy       d. shields          17-jun-81           level 81168
dsy    3 $
dsy    4 $    1.  extend iset option to allow several names separated by
dsy    5 $        plus signs.
dsy    6 $    2.  fix error (fr157) in that illformed conditional assembly
dsy    7 $        names were not detected.
dsy    8 $    decks affected - lexini, lexca, cainit (new)
dsy    9
nama   1
nama   2 $    nama      d. shields          28-apr-81           level 81118
nama   3 $
nama   4 $    increase dimension of names array for s10, s32 and s37 to permit
nama   5 $    full compilation of setl lib, v2.20.
nama   6
dsx    1
dsx    2 $    dsx       d. shields          12-nov-80           level 80317
dsx    3 $
dsx    4 $    for unix, initially define (set) symbol 'unix'. this avoids having
dsx    5 $    to specify 'iset=unix' for compilations in unix environment.
dsx    6 $    deck affected - lexini.
dsx    7
dsw    1
dsw    2 $    dsw       d. shields          21-jul-80           level 80203
dsw    3 $
dsw    4 $    correct problems in case folding.
dsw    5 $    enable trace options for unix checkout.
dsw    6 $    decks affected - macros, trulex, lexdir.
dsw    7
dsv    1
dsv    2 $    dsv       d. shields          10-jul-80           level 80192
dsv    3 $
dsv    4 $    1.  fix problem (fr135) in setting of termination code.
dsv    5 $        now issue code 0 if no warnings or errors, code 4 if warnings
dsv    6 $        and no errors, code 8 if any errors detected.
dsv    7 $    2.  add possibility of running with lower-case as primary case
dsv    8 $        used within the compiler. this obtained by setting -mcl-.
dsv    9 $    3.  do not generate 'no errors detected' message.
dsv   10 $    4.  add conditional symbol -unix- for the unix operating system.
dsv   11 $        use iset=unix to obtain unix variant.
dsv   12 $        want listing terse, make lcp=0 and lcs=0 the defaults.
dsv   13 $        for initial checkout, delete special env code (bskp, etc.).
dsv   14 $
dsv   15 $    decks affected - macros, lexini, trulex, lexexit.
dsv   16
dsu    1
dsu    2 $    dsu       d. shields          10-jan-80           level 80010
dsu    3 $
dsu    4 $    1.  extend dimension of names and macro arrays to permit
dsu    5 $        full compilation of setl lib phase.
dsu    6 $        this requires changing ha field definitions.
dsu    7 $    2.  redefine format of cross-reference file to permit input
dsu    8 $        file to have more than 32767 lines.
dsu    9 $    decks affected - macros, start.
dsu   10
dst    1
dst    2 $    dst       d. shields          03-jan-80           level 80003
dst    3 $
dst    4 $    1.  increase dimension of ha and macro table.
dst    5 $    2.  fix bug in list resume option
dst    6 $    decks affected - macros, start.
dst    7
dss    1
dss    2 $    dss       d. shields          04-dec-79           level 79338
dss    3 $
dss    4 $    if lower case supported, convert first character of
dss    5 $    source line to upper case as appropriate (fr2.3.128).
dss    6 $    deck affected - macros
dss    7
dsr    1
dsr    2 $    dsr       d. shields          19-nov-79           level 79323
dsr    3 $
dsr    4 $    1.  rewind token file for s66 only.
dsr    5 $    2.  use getapp (new lib procedure provided by mod dsc) to
dsr    6 $        obtain and list actual parameter string specified by user.
dsr    7 $    3.  delete code to read term= parameter and possibly open
dsr    8 $        terminal file, as this now done by lib (mod dsc).
dsr    9 $    decks affected - macros, lexini.
dsr   10
dsq    1
dsq    2 $    dsq       d. shields          02-aug-79           level 79214
dsq    3 $
dsq    4 $    1. convert to use string search primitives (provided by lib
dsq    5 $        level 79200) to support mixed-case source. case significant
dsq    6 $        only within character string constants.
dsq    7 $    2.  modify code to list line to provide tab character if
dsq    8 $        available so as to maintain alignment of source using tabs.
dsq    9 $    3.  add program parameter  'upd=0/1' such that upd=1 indicates
dsq   10 $        that lines in input file have upd sequence information in the
dsq   11 $        first eight columns.
dsq   12 $    4.  for s10, issue standard characters at start of error
dsq   13 $        and warning messages sent to terminal.
dsq   14 $    decks affected - macros, start, and principally trulex.
dsq   15
mgfa   1
mgfa   2 $    mgfa      m.g. ford           05-jul-79           level 79186
mgfa   3 $
mgfa   4 $    this mod performs some s10-only changes, to improve dec-10
mgfa   5 $    compatibility slightly. it requires associated mods in all
mgfa   6 $    other programs which are part of the little suite.
mgfa   7 $    1.  revamp default filenames.
mgfa   8 $    2.  have terminal open by default ('term=tty:/').
mgfa   9 $    3.  change from sixbit to 9-bit ascii (cs=9).
mgfa  10 $    decks affected - macros,lexini.
mgfa  11
dsp    1 $ dsp (79052) - adjust dimension of names for s10.
dso    1
dso    2 $    dso       d. shields          21 dec 78           level 78355
dso    3 $
dso    4 $    1.  fix error (fr.23.71) in that not all calls to -ermsg-
dso    5 $        specified three arguments.
dso    6 $    2.  delete trace code for s10, as bootstrap complete.
dso    7 $    decks affected - macros, those referencing -ermsg-.
dso    8
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/780.
vax    6 $    decks affected - macros, start, lexini.
vax    7
dsn    1
dsn    2 $    dsn       d. shields          25 sep 78           level 78268
dsn    3 $
dsn    4 $    1.  increase macro table length for setl use.
dsn    5 $    2.  add code for resident s10 compiler.
dsn    6 $    decks affected - macros, start, lexini.
dsn    7
       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 $    rbkh      r. kenner           01 mar 78           level 78060
      13 $              d. shields
      14 $
      15 $    1.  increase dimension of names for s37.
      16 $    2.  correct size error in lexdir.
      17 $    3.  avoid sending line twice just after  .=list input
      18 $    decks affected - macros, lexdir, givecr.
      19
      20
      21 $    rbkg      r. kenner           04 jan 78           level 78004
      22 $
      23 $    1.  correct some errors in s37 conditional code.
      24 $    2.  permit use of s-type tokens, which are delimited with
      25 $        code s, as in '3sabc'.  s-tokens are machine-dependent, and
      26 $        are for use on machines such as s10 and s11 with a 'system-
      27 $        format' string.
      28 $    3.  change 'subr start' to 'prog start' for s37 since no
      29 $        overlaying of phases occurs.
      30 $    4.  fix code mostly in -lexca- which handles work-to-do on a
      31 $        card since the gen 'fix' on taking .not. of a constant makes
      32 $        it incorrect as written.  (the problem is that ^(^1b'100') is
      33 $        ^(1b'11') which yields 1b'0', not the 1b'100' that
      34 $        might be expected.)
      35 $    5.  slightly clean up exit code in -lexexit- when no token file
      36 $        is specified.
      37 $    6.  correct bug in processing of -zzy- tokens in open text.
      38 $    decks affected - macros, start, lexini, lexdo, trulex, givecr,
      39 $                     lexca, lexdir, pflshr, lexexit
      40
      41
      42 $    dsm       d. shields          08 dec 77           level 77342
      43 $
      44 $    correct error in real constants with negative exponent.
      45 $    deck affected - trulex.
      46
      47
      48 $    rbkf      r. kenner           27 oct 77           77300
      49 $
      50 $    this mod improves the handling of programs with a lot of
      51 $    comment lines by not sending lines to gen unless the gen
      52 $    list option is on or the lines contain tokens.  in order
      53 $    for gen to keep the line numbers correct, the number of
      54 $    cards that a particular card represents is sent in the
      55 $    -toklc- field of the token for the card.
      56 $    this mod requires mod rbkk in gen.
      57 $    decks affected - start, lexdo, givecr, hash, lexexit
      58
      59
      60 $    rbkee     r. kenner           07 oct 77           77280
      61 $
      62 $    this mod corrects some errors in mod rbke.  the most important
      63 $    error was one in the routine -hash-.
      64 $    decks affected - macros, start, setlit, nextw, trulex, hash,
      65 $                     pflshr, ermsg
      66
      67
      68 $    rbke      r. kenner           07 sep 77           77250
      69 $
      70 $    this is mostly an internal cleanup mod.  the following are the
      71 $    major areas of change.
      72 $    1.  conditional code is added for s10 (dec system/10).
      73 $    2.  lexical punch code has been rewritten to bring it more
      74 $        up to date, clean it up, and clean up the format of
      75 $        the punched output.
      76 $    3.  -nextw-, -defabsrb-, and -mcexpand- are now only called
      77 $        when they are actually needed.  in most cases, most
      78 $        of the work is now done in -lexdo-.
      79 $    4.  error messages are now more informative and, in most
      80 $        cases, errors do not pass 'junk' to gen.
      81 $    5.  -astk- overflow is now not fatal but aborts macro
      82 $        expansion.
      83 $    6.  table definitions for s37 have been changed.
      84 $    7.  the dimension of the -ha- is now larger than the
      85 $        prime used to allow the first few clashes to be
      86 $        put in a separate area.  also, some tests have been
      87 $        reordered.
      88 $    decks affected - all (source has been resequenced)
      89
      90
      91 $    dsl       d. shields          26 jul 77           level 77206.
      92 $
      93 $    add program parameter 'termlex=0/1' to permit termination of
      94 $    compilation at end of lexical scan.
      95 $    decks affected - start, lexini, lexexit.
      96
      97
      98 $    dsk       d. shields          20 may 77           level 77140.
      99 $
     100 $    reported bug - macro '+* stk(a,b) = ; **' expands incorrectly.
     101 $    cause - special case code for one symbol macros did not check
     102 $        to see if macro had arguments.
     103 $    moral - special cases need special care.
     104 $    deck affected - defabs.
     105
     106
     107 $    dsjj      d. shields          05 may 77            level 77125.
     108 $
     109 $    reported bug - warning message for macro redefinition given twice.
     110 $    fix - remove duplicated code (introduced by mod dsj).
     111 $    deck affected - defabs.
     112
     113
     114 $    dsj       d. shields          08 april 1977       level 77098.
     115 $
     116 $    1.  improve diagnostic message if mstk overflow.
     117 $    2.  accept '.=member' directives in primary input file.
     118 $    3.  detect 'immediate', or one symbol macros, and use the macorg
     119 $        field to expand the macro, thus saving space in mtab.
     120 $        add the ha field 'macimm' which is on if macro is immediate.
     121 $        (suggested by art grand.)
     122 $    4.  increase dimension of mtab.
     123 $    decks affected - nextw, defabs, lexdir.
     124
     125
     126 $    dsi       d. shields          03 february 1977    level 77034.
     127 $
     128 $    1.  redefine origin of zzy and zzz symbols to be zero so first
     129 $        generated symbol or integer has index one.
     130 $    2.  use different counters for zzy and zzz symbols.
     131 $    3.  list active zzy counter values at end of scan.
     132 $    4.  increase length of macro table to permit compilation of new
     133 $        setl library.
     134 $    decks affected - macros, start, defabs, buildz, macexp,
     135 $        lexdir and lexexit.
     136
     137
     138 $    dsh       d. shields          31 january 1977     level 77031.
     139 $
     140 $    1.  adapt lex for s66 to support both 63 and 64 character sets.
     141 $        do this by accepting both 3b'63' and 3b'00' as valid forms of
     142 $        the 'colon' character in little.  implement by hashing these
     143 $        values in absolute form to initialize in imtoktab and setting
     144 $        literal codes of both entries to 70, the literal code for
     145 $        'colon'.
     146 $        code must be changed if literal code of colon changed.
     147 $        this change applies to s66 only - all code conditional.
     148 $    2.  repair error in trulex, which was not detecting real constants
     149 $        beginning with decimal point.
     150 $    3.  abort scan if input file empty.
     151 $    decks affected - lexini, trulex, lexexit.
     152
     153
     154 $    dsg       d. shields          07 january 1977     level 77007.
     155 $
     156 $    1.  repair error in -list- directive, as 'list input' was not
     157 $        recognized due to size introduced in prior mod.
     158 $    2.  define -zzy- counters to be one-origin, not zero origin.
     159 $    3.  at request of setl group, install directive to reset
     160 $        -zzy- counters.  the directive ' .=zzyorg' has as
     161 $        parameter a list of characters indicating the counters
     162 $        to be reset to one.  for example,
     163 $            .=zzyorg csr
     164 $        resets the counters zzyc, zzys and zzyr.
     165 $    4.  change keyword -debug- to -monitor-.
     166 $
     167 $    remaining changes adapt lex to new language level and library.
     168 $    trulex has been rewritten, and some source cleanup done.
     169 $
     170 $    5.  use -getipp- and -getspp- to obtain program parameters at
     171 $        execution time.
     172 $    6.  use new sio for io for token, punch and reference files.
     173 $    7.  keep macro argument count, which was ha field -macargs-, as
     174 $        first entry in macro text table -mtab-.
     175 $    8.  revise hash algorithm to use algorithm 'c' of knuth
     176 $        (see comments in procedure -insglor- in -gen-).
     177 $    9.  pad -names- entries with blanks, not binary zeros.
     178 $   10.  recode trulex to support only new language level.
     179 $        salient points are as follows:
     180 $        1.  drop support of token types -d-, -h-, -z-, -l- and -b-.
     181 $        2.  assign -q- tokens lexical type -stringtok-, as q tokens
     182 $            are just another way of writing character strings.
     183 $        3.  avoid use of finite state automaton to drive scan.
     184 $            large number of special actions makes straight code
     185 $            clearer and more efficient.
     186 $        4.  distinguish two cases of 'get next character' primitive.
     187 $            use -givec(c)- to get character via procedure call.
     188 $            use -giveq(c)- to get character via inline code.
     189 $        5.  implement -givecstr- primitive as procedure cal.
     190 $        6.  code for -ieof- end of file option retained, but is
     191 $            probably incorrect if enabled.
     192 $
     193 $    source has been resequenced.
     194 $
     195 $    decks affected - all.
     196
     197
     198 $    dsf       d. shields          20 november 76      level 76325.
     199 $
     200 $    convert to use new -sio.  drop use of following routines:
     201 $        opnpun, putpun, clspun, opntok, puttok, clstok.
     202 $    decks affected: macros, start, lexini, pncr, lexexit.
     203
     204
     205 $    rbkd      r. kenner           1 november 76       level 76306
     206 $
     207 $    fix bug in macro processor causing stores into the zero word
     208 $    of -astk-.
     209 $    deck affected - nextw
     210
     211
     212 $    dse       d. shields          8 oct 76            level 76282.
     213 $
     214 $    add literals:  read  write  prog  .seq.  .sne.
     215 $    literal codes   93     94    95     96     97  .
     216 $    deck affected - inslit.
     217
     218
     219 $    rbkc      r. kenner           29 july 76          level 76211
     220 $
     221 $    1.  fix bug causing compilation error if -oldtoks- is set.
     222 $    2.  fix bug in -lexca-.
     223 $    3.  change -slen- macro to use .len.
     224
     225 $    rbkb      r. kenner           21 july 76          level 76203
     226 $
     227 $    1.  add conditional option 'oldtoks' to allow usage of old-style
     228 $        tokens.  in this mode, an error message will be given for
     229 $        each such token.  if 'oldtoks' is not set, usage of old-style
     230 $        tokens is not allowed.
     231 $    2.  add literal codes for 'limit', 'debug', and 'rewind'.
     232 $    3.  improve error message content and format.
     233 $    4.  change parameter used to specify an initial inclusion
     234 $        member to 'imem' (it was -incl-).
     235 $    5.  support 'term' parameter.  it specifies a file name to
     236 $    receive copy of error messages.
     237 $    6.  add -ejectl- and -stitlr- calls to improve formatting of
     238 $        output listing.
     239 $    7.  extend listing control by rewriting -givecr- and
     240 $        adding -lexca- to handle condition processing.  -lexca-
     241 $        replaces some code previously in -givecr- and is called
     242 $        by -givecr-.  changes at the user level are:
     243 $        1.  the list parameter -sinput- has been changed to
     244 $            -linput- and the corresponding letter in the 'list'
     245 $            compilation parameter is now 'l' instead of 's'.
     246 $        2.  the following parameters have been added to the -list-
     247 $            directive:
     248 $                    autotitle          instructs -gen- to use the
     249 $                                       -subr- or -fnct- statement as
     250 $                                       a subtitle and use 'title'
     251 $                                       directives as main title.
     252 $                    skip               instructs -gen- to list lines
     253 $                                       of text skipped by conditional
     254 $                                       processing.
     255 $                    qualifiers         instructs -gen- to list the
     256 $                                       conditional qualifiers.
     257 $                    directive          instructs -lex- and -gen- to
     258 $                                       list the directive on which
     259 $                                       this parameter appears.
     260 $            note that 'no' may preceed each of these to negate the
     261 $            effect and that each may be indicated in the compiler
     262 $            'list' parameter by its first letter.
     263 $            also, 'dir'/'nodir' may appear on 'punch'.
     264 $        3.  default is  .=list noaut,nolin,noinp,nocod,ref,noski,noqua
     265 $
     266
     267
     268 $    dsd       d. shields          28 june 76          level 76180.
     269 $
     270 $    revise listing control.
     271 $        lines with ' .=' in columns 1 through 3 are directives.
     272 $
     273 $        the ' .=title' directive sets the listing title.  the
     274 $        directive contains a quoted string which is the title text.
     275 $        the first title directive defines the main title which appears
     276 $        on the top of each page; remaining directives set the subtitle
     277 $        and cause a page eject.
     278 $
     279 $        the ' .=eject' directive begins a new page of listing.
     280 $        an optional integer parameter may be supplied, in which case
     281 $        a new page is begun only if less than the indicated number of
     282 $        lines remain on the current listing page.
     283 $
     284 $        the ' .=list' and ' .=punch' directives control listing and
     285 $        macro 'punch' control, respectively.
     286 $        each of these directives may contain a list of parameters,
     287 $        separated by commas.
     288 $        an option is disabled by putting the letters 'no' in front.
     289 $        only the first three characters of the parameter code are
     290 $        examined.
     291 $
     292 $        the parameters for the punch directive are 'define', to
     293 $        punch macro definitions and 'expand' to punch expanded text.
     294 $
     295 $        the parameters for the list directive are as follows:
     296 $            code - list generated code.
     297 $            input - list source input in parse (gen) phase.
     298 $            ref - collect references if cross reference feature on.
     299 $            sinput - list source input in scanner (lex) phase.
     300 $
     301 $        all options are off by default except for 'ref'.
     302 $
     303 $        a stack is kept of the most recent twenty or so list
     304 $        directives. the parameter 'resume' may be used to restore
     305 $        list control to that established by the previous list directiv
     306 $
     307 $        the list directives may be initialized by the control card
     308 $        option 'list' which accepts a list of character codes.
     309 $
     310 $            c   enable 'code' option.
     311 $            d   enable 'define' option for punch.
     312 $            e   enable 'expand' option for punch.
     313 $            i   enable 'input' option.
     314 $            s   enable 'sinput' option.
     315 $            0   ignore list directives in input.
     316 $
     317 $        if 'list' alone occurs, 'list=i' is implied.
     318 $
     319 $    include feature for remote text.
     320 $
     321 $        directives of the form ' .=include  name' indicate that
     322 $        the line in the text is to be replaced by member 'name' of
     323 $        a text library.  the compiler option 'ilib' may be used to
     324 $        name a member to be included before the input file is read,
     325 $        thus permitting inclusion of a standard text prelude.
     326 $
     327 $        inclusion processing is contained in the new library routines
     328 $        'opninc', 'getinc' and 'clsinc' which are similar to the
     329 $        routines 'opninp', 'getinp' and 'clsinp' previously used to
     330 $        read the input file.
     331 $
     332 $    environment symbol '.compdate.' for compilation date.
     333 $
     334 $        an instance of the symbol .compdate. is replaced by a
     335 $        character string of length 30 which gives the date of
     336 $        compilation.  the format is that returned by the 'lctime'
     337 $        library primitive.
     338 $
     339 $    use of new library listing features.
     340 $
     341 $        this version of lex uses the extended version of the standard
     342 $        print routines which recognizes pages and permits page titles.
     343 $
     344 $    decks affected = all.
     345
     346
     347 $    rbka      r. kenner           24 may 76           level 76147.
     348 $              d. shields
     349 $
     350 $    1.  use ps for ws whenever possible (better on s37).
     351 $    2.  allow 'iset' option to set initial conditional name;
     352 $        for example, 'iset=tr' corresponds to insertion of card
     353 $        ' .+set tr' before start of input.
     354 $    3.  generate initial set for symbol 'snn' where nn is target
     355 $        machine as determined by 'tm' option.
     356
     357
     358 $    cra       d. shields          04 may 76               level 76125
     359 $
     360 $    cross-reference processing is now done as follows.
     361 $    the individual routine reference list is no longer available, as
     362 $    global map obtained by compiling routines of interest provides
     363 $    essentially the same information.
     364
     365 $    the lexical phase writes two files.  the reference file contains
     366 $    a list of ha indexes and line numbers.  the ha file defines the
     367 $    ha and includes a count of the total number of references, etc.
     368 $    the gen phase writes a third file which indicates the subroutine
     369 $    boundaries.
     370 $
     371 $    the reference list is generated by a separate program, 'ref',
     372 $    which reads in the files, sorts the ha and reference list,
     373 $    eliminates duplicate references and formats the listing.
     374 $
     375 $    reference file 1 contains a list of references, each defined by
     376 $    three fields:
     377 $    1.  line number
     378 $    2.  ha index of symbol.
     379 $    3.  flag set if name currently is macro.
     380 $    the list is terminated with a zero entry.
     381 $
     382 $    structure of reference file 2 is as follows:
     383 $    each entry is word-size.
     384 $    1.  total number of references.
     385 $    2.  last line number.
     386 $    3.  ha dimension.
     387 $    4.  number of words required to store names in ha.
     388 $    there follow a variable number of entires defining the ha,
     389 $    as follows:
     390 $        1.  ha index.
     391 $        2.  length of name.
     392 $        3.  name, packed cpw characters per entry, and
     393 $            right adjusted.
     394 $
     395 $    every ha entry referred to in the reference list must be
     396 $    specified.
     397 $    the list is terminated by an entry of 0.
     398 $
     399 $    the files are written using -sio- with fixed-length records.  the
     400 $    record length is a parameter, -crbuffmax-, whose value must agree
     401 $    with that used in -gen- and -ref-.
     402 $
     403 $    the files are identified internally by number.  the parameter
     404 $    'rf' gives a file name skeleton from which the name is generated
     405 $    by replacing the last numeric character by the appropriate numeric
     406 $    character.  the library routine -crfnam- performs this task.
     407
     408 $    the suspicious variables function is now realized by internal
     409 $    sort of ha.
     410 $    routines affected - macros, start, hash, detect, lexexit.
     411 $    routines deleted - maklinz, mastlis, purger, sorter, mem.
     412 $    the source has been resequenced.
     413
     414
     415 $    dsc       d. shields          19 april 1976       level 76110
     416 $
     417 $    support revised form of bit string constants.  this form consists
     418 $    of a 'width' specifier of 1,2,3 or 4 followed by 'b' and then
     419 $    immediately followed by a quoted string containing blanks and bit
     420 $    values.  the width indicates the number of bits defined by each
     421 $    nonblank character.  the characters 'a', 'b', 'c', 'd', 'e' and
     422 $    'f' are used for width 4 in the usual hexadecimal sense.
     423 $    for example, the integer 13 is equivalent to each of the following
     424 $    bit constants:  1b'1101'  2b'31'  3b'15'  4b'd' .
     425 $    the 'b' and 'l' format bit constants will soon be dropped.
     426 $    decks affected - macros, lexini, trulex, lexexit, ermsg.
     427
     428
     429 $    dsb       d. shields          14 april 76         level 76105
     430 $
     431 $    1.  use .ws., .ps., etc. for machine parameters.
     432 $    2.  be more consistent in use of tokch.
     433 $    3.  correct errors in generation of 'zzz' type tokens.
     434 $    4.  replace 'goby' statements with indexed 'go to'.
     435 $    decks affected - macros, lexini.
     436
     437
     438 $    dsa       d. shields          25 march 1976       76085
     439 $
     440 $    continue work on system/370 version, as follows.
     441 $    1.  eliminate uses of eqsds, .s. and .e.
     442 $    2.  use lctime to obtain time and date.
     443 $    3.  change name countupr to ltoflo.
     444 $    4.  initialize some previously unitialized variables.
     445 $    5.  change fivdec to return array of chars, not string.
     446 $
     447$     the source has been resequenced.
     448
     449
     450 $    ldsy      d. shields          20 january 1976     level 76020
     451 $
     452 $    1.  allow up to 31 arguments in macros.
     453 $        (this has required change in litcod field position.)
     454 $    2.  eliminate 'no list dollar' option.
     455 $    3.  add options 'lcp' and 'lcs' to allow selection of
     456 $        listing of parameters and statistics.
     457 $        'lcp=0' suppresses parameter listing.
     458 $        'lcs=0' supresses statistics listing.
     459 $    4.  add option 'lel' to permit selection of maximum allowed
     460 $        number of errors.
     461 $    5.  change format of parameter listing.
     462 $    decks affected - start, lexini, givec, lexexit, ermsg.
     463
     464
     465  $   ldsx      d. shields          01 january 1976     level 76001
     466 $
     467 $    change literal codes to correspond to level 76001 of gen.
     468 $    fix error in purger, so duplicate entries eliminated.
     469 $    decks affected - setlit, purger
     470
     471
     472 $    ldsw      d. shields          06 november 1975    level 75310
     473 $
     474 $    1.  if a name used as a macro within a routine, insert '+*' on
     475 $        first line of reference list for each routine.
     476 $    2.  do not collect references to 'subr' or 'fnct'.
     477 $    decks affected - macros, hash, maklinz
     478
     479
     480 $    ldsv             d. shields         27 october 1975
     481 $
     482 $    eliminate literal codes for io keywords no longer used:
     483 $          17'readb'  18'read'  19'writb 20'write  22'endfile'
     484 $    and define new literal codes as follows:
     485 $          17'elseif'  18'in'  19'.sds. 20'.voapart.'
     486 $    (code 22 thus not used now).
     487 $    the level is now 75300.
     488 $    deck affected - setlit
     489
     490
     491 $    ldsu          d. shields         15 september 1975
     492 $
     493 $    reported bug - not all subroutine boundaries seen by cross-ref opt
     494 $    fix - fine tune the automaton in hash to detect case when routine
     495 $    ends in 'end' followed by literals followed by 'end subr/fnct'.
     496 $    deck affected - hash
     497 $    the level is now 75258.
     498
     499
     500 $    ldst          d. shields       7 july 75
     501 $
     502 $    the line numbers in the 'complete' cross-reference map
     503 $    (xra=1) are now given relative to the start of the routine.
     504 $    the level is now 75188.
     505 $    decks affected - purger, mastlis, maklinz
     506
     507
     508 $    ldss       d. shields        2 july 75
     509 $
     510 $    reported bug - routine boundaries not seen during cross-
     511 $    reference listing generation.
     512 $    fix - -hash- was not passing tokens 'subr' 'fnct' and 'end'
     513 $    to cross reference code.
     514 $
     515 $    the 'tally' option is now expressed as separate options
     516 $    'tallytokens', 'tallycomments' and (new) 'tallyhash', which
     517 $    measures symbol table access.
     518 $    deck affected - hash
     519 $    the level is now 75183.
     520
     521 $    ldsr          d. shields         4 june 75
     522 $
     523 $    this ident simplifies some of the initializations, particularly
     524 $    for the literals.  new literals
     525 $        .ws.  .ps.  .cs.  .sl.  .so.
     526 $    have been added, in anticipation of 'machine parameter' option.
     527 $    the level is now 75155.
     528 $    decks affected - lexini, setlit
     529
     530
     531 $    ldsq         d. shields      30 may 75
     532 $
     533 $    this correction changes the handling of file names to use
     534 $    sds format names instead of machine dependent z-format
     535 $    previously used.
     536 $    file names of up to -filenamelen- chars (currently 20) are
     537 $    allowed.  default names are given by macros which may be
     538 $    adjusted to fit different systems.
     539 $    control card parameters are now obtained using
     540 $    library routine -reados-.
     541 $    the format of error messages has been changed.
     542 $    decks affected - macros,lexini,ermsg(resequenced
     543 $    the level is now 75150
     544
     545
     546 $    nmchar       d. shields       23 may 75
     547 $
     548 $    this correction extends the language to include n-type tokens.
     549 $    n-type tokens are used to define names and are similar in format
     550 $    to the -r-, -h-, -z-, and -d- tokens, except the letter -n- is
     551 $    used.  n-type tokens permit the use of non-standard characters
     552 $    in names; possible uses include protection of library
     553 $    names to avoid conflict with user names.  for example,
     554 $    'call 3nio.(a,b)' is a call to routine with name 'io.'.
     555 $    the level is now 75143.
     556 $    decks affected - lexini, trulex
     557
     558
     559 $    ldsp             d. shields           9 april 75
     560 $
     561 $    reported bug - string 'zzzz' processed as though were name.
     562 $    fix - restrict test for zzz-zzy type tokens to names.
     563 $    the level is now 75099.
     564 $    decks affected - nextw, dfabsrb
     565
     566
     567 $    astkmsg       d. shields      31 march 75
     568 $
     569 $    this correction provides improved diagnostic support if
     570 $    macro argument has unbalanced parenthesies.  previously,
     571 $    the scanner continued search over input until -astk- overflow
     572 $    occurred, causing fatal termination.  the resulting messages
     573 $    were confusing to users and provided little help, as error
     574 $    actually occurred several hundred tokens before point of overflow.
     575 $    the new scheme is as follows - when we start to collect a macro
     576 $    argument, we save current line number; during argument collection
     577 $    we watch for argument overflow, so that we can indicate most likel
     578 $    source of problem.
     579 $    the level is now 75090.
     580 $    decks affected - macros (astkput only), nextw, ermsg.
     581
     582
     583 $    litcod        e deak              23 feb 75
     584 $
     585 $    all keywords and literals are given literal codes.
     586 $    a litcod field is set in the ha for them (lexini). the
     587 $    literal code is passed to gen in tokhdr in new field tokrlc.
     588 $    the mapping of literals onto litcodes must be identical in gen
     589 $    and lex.
     590 $    decks affected are macros, hash, detect, genini
     591
     592 $
     593 $    ldso        d. shields       6 march 75
     594 $
     595 $    reported bug - unexpected instance of '/ *' within
     596 $        pl1 comment observed.
     597 $    fix - trulex had incorrect test for termination of pl1
     598 $    style comment if even number of * preceded terminal /.
     599 $    the level is now 75065.
     600 $    deck affected - trulex
     601 $
     602
     603 $    ldsn         d. shields       18 february 75
     604 $
     605 $    to dimensions of -ha- and -names- have been increased to permit
     606 $    compilation of -gen- which supports new i/o features.
     607 $    the level is now 75049.
     608
     609 $    ldsm          d. shields          6 november 74
     610 $
     611 $    reported bug - sequence '1. else' converted to '1. lelse'.
     612 $    fix - error in detection and backup of real constants
     613 $    fixed in trulex.
     614 $    reported bug - punch routines punch '1b' as '21b'.
     615 $    fix - octal tokens were being handled as though
     616 $    they were strings by -pncr-.  test of token type fixed.
     617 $    the initialization of actab has been adjusted so that names
     618 $    always collected in separate loop, and comment just following
     619 $    definition of actab in trulex has been brought up to date.
     620 $    the level is now 74310.
     621 $    decks affected - lexini, trulex, pncr.
     622
     623 $    ldsl          d shields           6 november 74
     624 $
     625 $    this correction modifies definition of real constants so that
     626 $    blanks only allowed inside such constants if they occur between
     627 $    two numeric characters.  the previous definition, while satis-
     628 $    factory for little, caused problems in new setl front end.
     629 $    the macros -addtotok-, -retbuf- and -abuf- are no longer needed,
     630 $    and so have been eliminated, as have variables
     631 $    numflag and expflag within trulex
     632 $    decks affected - macros, trulex
     633
     634
     635 $    ldsk          d shields           7 october 74
     636 $    this correction makes a few changes to ease system/370 bootstrap
     637 $    -  time and date now expressed by functions -timestr- and
     638 $        -datestr- which return array of characters (8)
     639 $    -  control card parameters and file names changed to not exceed
     640 $        four characters in length
     641 $    -  default for -detect- option changed to -no- for 370 to
     642 $        avoid use of random/access routnes in initial bootstrap
     643 $    deck affected - macros, start, lexini
     644 $    the level is now 74280
     645
     646 $
     647 $    ldsj             d. shields       13 august 74
     648 $
     649 $    this correction set
     650 $    1.  fixes two errors in trulex in detection of real constants
     651 $        (bug reported and fixed by d. mirante).
     652 $    2.  reduces mtab size to 8000 from 12000.
     653 $    3.  corrects countup macro (quitting one entry too soon).
     654 $        last line listed if abort via countup.
     655 $    4.  dayfile message suppressed if no errors.
     656 $    the level is now 74225
     657 $    decks affected - macros,trulex, users of -countup- macro
     658 $
     659
     660 $    ldsi          d shields      29 july 74
     661 $
     662 $    this correction fixes an error in macro-processor, slightly
     663 $    recodes  a test which inadvertently was calling off-line
     664 $    multi-word routines.
     665 $    - the error in detect causing  only last line to be listed
     666 $        has been fixed.
     667 $    decks affected - macros, nextw, detect
     668 $    the level is now 74210
     669
     670 $    ldsh         d. shields        18 july 74
     671 $
     672 $    this correction fixes error in trulex in handling of blanks
     673 $    inside numerical constants.
     674 $    the level number is now 74199
     675 $    deck affected - trulex
     676
       1 .=member macros
       2
       3      $   conditional assembly options.
       4
       5
dsq   16      $   select lc if lower-case characters available.
dsq   17
dsv   17 .+set mc  $ assume mixed-case characters available.
dsv   18
dsv   19 $    if mixed-case available, default primary case is upper.
dsv   20 $    obtain lower primary case by defining mcl.
dsq   19
       6      $   select mp to include little macroprocessor.
       7 .+set mp
       8
       9      $   select ca to include conditional assembly feature.
      10 .+set ca
      11
      12      $   select cr to include cross-reference function.
      13 .+set  cr
      14
      15      $   following options used to collect performance statistics.
      16      $   select tallycomments to count number and type of comments.
      17 .+set  tallycomments
      18
      19      $   select tallytokens to count number of tokens sent to parser.
      20 $-set tallytokens
      21
      22      $   select tallyhash to monitor hash table probes.
      23 .+set  tallyhash
      24
      25      $   select ht to include code supporting .hatr. and .nohatr.
      26      $   ha trace tokens.
      27 $-set ht
      28
      29      $   select ct to include code supporting .chtr. and .nochtr.
      30      $   character trace tokens.
      31 $-set  ct
      32
      33      $   select mt to include code supporting .mactr. and .nomactr.
      34 $-set  mt
      35
      36      $   select mtgc to include empty entry at start of each macro
      37      $   definition to permit macro garbage collection.  as garbage
      38      $   collector not expected soon, text usually not included.
      39 .-set  mtgc
      40      $   select bub if scanner runs together with parser which requires
      41      $   token back-up (bub stands for b-ack u-p b-uffer).  do not
      42      $   select if scanner runs as separate parse phase or job step.
      43 .-set  bub
      44
      45      $   select sdspack_env if special library code provided to do
      46      $   token pack into hashtok.
dsn    8 .+s10.
dsn    9 .+set  movea_env
dsn   11 .+set  sdspack_env
dsn   16 ..s10
      47 .+s66.
      48 .+set  sdspack_env
dsv   21 .-set mc  $ s66 upper-case only
      49 ..s66
utsb   1
utsb   2 .+s32.
utsb   3 .+set s32v  $ assume vms.
utsb   4 ..s32
utsb   5
utsb   6 .+s32u.
utsb   7 .+s32.
utsb   8 .-set s32v  $ do not want vms.
utsb   9 .+set s32u  $ want unix os.
utsb  10 ..s32
utsb  11 .+set mcl   $ want primary case to be lower.
utsb  12 ..s32u
utsc   1
utsb  14 .+s32.
vaxb   1 .+set sdspack_env,bskp_env,movea_env
vax   11 ..s32
      50 .+s37.
      51 .+set sdspack_env,bskp_env,movea_env
      52 ..s37
utsa   8 .+s47.
utsa   9 .+set mcl  $ primary case is lower
utsa  10 .-set sdspack_env,bskp_env,movea_env
utsa  11 ..s47
      53
      54      +*  scannerlevel =  $ julian date of last scanner change
ldsa  10           'lex(81324)'  $ 20-nov-81
      56      **
      57
      58
utsb  15 .+s32u.
dsv   24 $    configure for unix, set primary case lower.
dsv   25 .+set mcl
dsv   26 $    for initial checkout, delete efficiency env options.
dsv   27 .-set sdspack_env,bskp_env,movea_env
utsb  16 ..s32u
      59
      60
      61
      62      +*  ws = .ws. **  $ machine word size in bits.
      63
      64      +*  ps = .ps. **  $ machine pointer (address) size in bits.
      65
      66      +*  cs = .cs. **  $ character size in bits.
      67
      68      +*  slen = .len. **  $ length field of self-defining string (sds)
      69
      70      +*  sorg = .f. .sl.+1, .so., **  $ origin field of sds.
      71
      72      +*  sds(n) = .sds. (n) **  $ size of n-character sds.
      73
      74      +*  cpw = (ws/cs) **  $ no. of characters in machine word
      75
dsv   29 .+mc.
dsv   30 .+mcl.   $ if mixed-case to be lower
dsv   31      +*  ctpc(x) = ctlc(x) **  $ primary case is lower.
dsv   32      +*  stpc(x) = stlc(x) **  $ primary case is lower.
dsv   33 .-mcl.
dsv   34      +*  ctpc(x) = ctuc(x) **  $ primary case is upper.
dsv   35      +*  stpc(x) = stuc(x) **  $ primary case is upper.
dsv   36 ..mcl
dsv   37 ..mc
      82      +*  ms = $ size of macro definition item (must divide ws)
      83 .+s66    15
vax   14 .+s32    16
      84 .+s37    16
utsa  12 .+s47    16
habb   1 .+s10    18
      86          **
      87
      88      +*  wpc =   $ number of words per card
      89 .+s66    9 $ read 9 words (90 columns) for cdc 6600
vax   15 .+s32    20  $ assume 80 columns in input card
      90 .+s37    20  $ assume 80 columns in input card
utsa  13 .+s47    20  $ assume 80 columns in input card
mgfa  14 .+s10    20  $ assume 80 columns in input card.
      92          **
      93
      94      +*  filenamelen =  20 ** $ maximum file name length in chars
vaxc   1 .+s32    +*  filenamelen =  64 ** $ maximum file name length in chars
utsa  14 .+s47    +*  filenamelen =  64 ** $ maximum file name length in chars
      95
      96      +*  tokenfile = 3 **  $ token file number.
      97
dsr   12 $    getapp_len is length of actual parameter string (cf. lexini).
dsr   13          +*  getapp_len = 128  **
dsr   14 .+s32    +*  getapp_len = 240 **
utsa  15 .+s47    +*  getapp_len = 240 **
      98
      99      +*  punchfile = 6 **  $ punch file number.
     100
     101      +*  crfile = 5 **  $ cross reference file number.
     102
     103 .+cr.
     104      $   fields of cross-reference entry.
dsu   12      +*  cref_line  = .f. 01, 16, **  $ line number of reference.
ldsa  11      +*  cref_ha    = .f. 17, 14, **  $ ha index of item.
ldsa  12      +*  cref_macro = .f. 31, 01, **  $ 'is name currently macro'.
     108
     109      +*  crbuffmax = 256 **
     110
     111      +*  crefput(i) =
     112          crbuffptr = crbuffptr + 1;
     113          crbuff(crbuffptr) = i;
     114          if  crbuffptr = crbuffmax  then
     115              call wtrwsio(crfile, iorc, crbuff, 1, crbuffmax);
     116              crbuffptr = 0;
     117              end if;
     118          **
     119 ..cr
     120      +*  lstimelen = 30 **  $ length of lstime time representation.
     121      +*  mccd = 72 **  $ rightmost column of input processed
     122      +*  numbugtoks = 9 **   $ number of special period delim toks
     123      +*  listarglim = 31 **  $ max. no. of macro arguments.
     124          $ arguments, is dimension is array listarg in routine nextw
     125      +*  namesmax =          $ dimension of names array.
ldsa  13 .+s32    12000
ldsa  14 .+s37    12000
utsa  16 .+s47    12000
ldsa  15 .+s66    5000
ldsa  16 .+s10    12000
     129          **
     130
     131      +*  mtlim =  $ max. number of entries in mtab, macro def. table.
dsu   19          10000
     133          **
     134
     135      +*  mstklim = 100 ** $ limit of mstk.
     136
     137      +*  lsvtkz = 15 **  $ dims of -lsvtk-, must be 2**k-1
     138
     139
     140 .+bub    +*  reslim = 20 **  $ limit on reserved token stack in nextw
     141
     142      +*  maxtoklen = 127 **  $ max. token length in characters
     143      +*  hashtokorg = $ origin for hashtok string, fixed always
     144          (1 + .sds. (maxtoklen+cpw)) **
     145
     146      +*  listprevmax = 10 **   $ depth of listing status saved.
     147
     148      +*  tokrbuflim = 256 **  $ no of entries in token buffer
     149
     150      +*  hasz = $ size of ha in bits
dsu   20 .+s66    120
vax   17 .+s32    64
     152 .+s37    64
utsa  17 .+s47    64
     153 .+s10    72
     154      **
     155
     156 $        note that the dimension of the ha must be a prime
     157 $    selection of primes is machine dependent and is discussed in
     158 $    'the art of computer programming', d. e. knuth, vol 3.
     159 $    pp 508-509.
     160 $    in brief, condition is to find p such that
     161 $    r exp k is not congruent to a modulo p, where
     162 $    r is radix of character set (64 for 6600),
     163 $    k and a are small integers.
     164 $    not that if r exp k is congruent to a mod p, then
     165 $    hash of 'ab' is close to sume of hash 'a' and hash 'b'.
     166
     167 $    suggested values for s66 are: 4073, 3613, 3329, 2969.
     168
ldsa  17 .+s66   +* haprime = 3929 ** $ keep old value for s66
ldsa  18 .-s66  +* haprime = 4507 **
     170
     171      +*  hadim = (haprime + haprime/25) **  $ leave space at top.
     172
     173      +*  suspi=2 **  $  nuses threshhold used by detect
     174
     175
     176      +*  sdstl  =  $ macro giving needed size for std token string
     177          (.sds. 20) **
     178
     179 $      macros for token types assigned by scanner
     180
     181      +*  nametok = 1         **  $  name
     182      +*  spectok = 2         **  $  special, eg  () + -
     183      +*  optok  = 3          **  $  period delimited operator, eg  =
     184      +*  dectok = 4          **  $  decimal integer, eg  100
     185      +*  sstok = 5 **    $ 'special' string token
     186      +*  stringtok = 6       **  $  constant string, eg  'message'
     187      +*  bittok = 8 **       $ bit string
     188      +*  rztok = 12 **       $ r-type token, right zero fill
     189      +*  realtok = 14 **          $ real constant
     190
     191      +*  cpstr = $ characters per short token record
     192 .+s66    6
vax   18 .+s32    1
     193 .+s37    1
utsa  18 .+s47    1
mgfa  16 .+s10    1
     195          **
     196
     197      +*  listcontroltok = 27 **  $ .=list directives.
     198      +*  listejecttok   = 28 **  $ .=eject directive.
     199      +*  listtitletok   = 29 **  $ .=title directive.
     200      +*  tokrcard = 30 **    $ tyoen-record code for card image
     201      +*  tokreof = 31 **     $  token file code for end-of-file
     202 .-s66.   $ new values.
     203      +*  tokrtyp = .f. 1, 8, **  $ token-record code for lexical type
     204      +*  tokrlen = .f. 9, 8, **   $  toeen-record code for no of chars
     205      +*  tokrlc = .f. 17, 8, **  $ token literal code
     206 .+s66.  $ old values for now.
     207      +*  tokrtyp = .f. 1, 5, **
     208      +*  tokrlen = .f. 7, 7, **
     209      +*  tokrlc = .f. 14, 9, **
     210 ..s66
     211      +*  tokrval =  $ value part of header word (first few token chars)
     212 $    (holds cpstr characters)
     213          .f. ws+1 - cpstr*cs, cpstr*cs, **
     214
     215 $    the following macros define characters used to identify
     216 $    the various character string constants.
     217      $   ha fields are as follows:
     218
     219      $   nameptr - start of name in names array.
     220      $   lextyp - token lexical type, one of nametok, bintok, etc.
     221      $   lexlen - token length in characters.
     222      $   litcod - literal code if literal.
     223      $   nuses - number of token occurrences.
     224      $   macorg - start of macro definition in mtab.
     225      $   cab - conditional assembly state of name.
     226      $   halink - ha index of next entry in hash chain.
     227
     228
ldsa  19 .+s66.
ldsa  20      +*  lextyp     = .f. 01, 04, **  $ lexical type.
ldsa  21      +*  lexlen     = .f. 05, 07, **  $ lexical length.
ldsa  22      +*  litcod     = .f. 12, 07, **  $ literal code number.
ldsa  23 .+ca +*  cab        = .f. 19, 01, **  $ conditional assembly bit.
ldsa  24      +*  nameptr    = .f. 20, 13, **  $ names index.
ldsa  25 .+mp +*  macorg     = .f. 61, 14, **  $ macro origin.
ldsa  26      +*  nuses      = .f. 46, 02, **  $ number of uses.
ldsa  27      +*  halink     = .f. 75, 13, **  $ link for hash chain.
ldsa  28 .+mp +*  macimm     = .f. 60, 01, **  $ 'is this immediate macro'.
ldsa  29 ..s66
ldsa  30 .+s32.
ldsa  31 .+ca +*  cab     = .f.  1,  1, **
ldsa  32 .+mp +*  macimm  = .f. 49,  1, **
ldsa  33      +*  nameptr = .f.  2, 14, **
ldsa  34      +*  lextyp  = .f. 16,  4, **
haba   1 .+mp +*  macorg  = .f. 50, 14, **
ldsa  36      +*  lexlen  = .f. 33,  7, **
ldsa  37      +*  litcod  = .f. 40,  7, **
ldsa  38      +*  nuses   = .f. 47,  2, **
ldsa  39      +*  halink  = .f. 20, 13, **
ldsa  40 ..s32
ldsa  41 .+s37.
ldsa  42 .+ca +*  cab     = .f.  1,  1, **
ldsa  43 .+mp +*  macimm  = .f. 49,  1, **
ldsa  44      +*  nameptr = .f.  2, 14, **
ldsa  45      +*  lextyp  = .f. 16,  4, **
haba   2 .+mp +*  macorg  = .f. 50, 14, **
ldsa  47      +*  lexlen  = .f. 33,  7, **
ldsa  48      +*  litcod  = .f. 40,  7, **
ldsa  49      +*  nuses   = .f. 47,  2, **
ldsa  50      +*  halink  = .f. 20, 13, **
ldsa  51 ..s37
utsa  19 .+s47.
utsa  20 .+ca +*  cab     = .f.  1,  1, **
utsa  21 .+mp +*  macimm  = .f. 49,  1, **
utsa  22      +*  nameptr = .f.  2, 14, **
utsa  23      +*  lextyp  = .f. 16,  4, **
haba   3 .+mp +*  macorg  = .f. 50, 14, **
utsa  25      +*  lexlen  = .f. 33,  7, **
utsa  26      +*  litcod  = .f. 40,  7, **
utsa  27      +*  nuses   = .f. 47,  2, **
utsa  28      +*  halink  = .f. 20, 13, **
utsa  29 ..s47
ldsa  52 .+s10.
ldsa  53      +*  nameptr = .f.  1, 18, **
ldsa  54 .+mp +*  macorg  = .f. 19, 18, **
ldsa  55      +*  lexlen  = .f. 37,  7, **
ldsa  56      +*  nuses   = .f. 44,  2, **
ldsa  57 .+ca +*  cab     = .f. 46,  1, **
ldsa  58      +*  litcod  = .f. 47,  7, **
ldsa  59      +*  lextyp  = .f. 54,  4, **
ldsa  60 .+mp +*  macimm  = .f. 58,  1, **
ldsa  61      +*  halink  = .f. 59, 13, **
ldsa  62 ..s10
     262
     263
     264
     265      $   io access codes.
     266      +*  access_put = 3 **
     267      +*  access_write = 6 **
     268
     269
     270 $        macros for output
     271
     272 $    routines called by these macros are in little run-time
     273 $    library.
     274 $    macros are to appear where statement may appear; semicolon indicat
     275 $    end of statement supplied by macro expansion.
     276
     277      +*  charl(c) = call charlr(c); **  $ output character
     278      +*  intl(i) = call intlr(i); **  $ output integer (5 digits)
     279      +*  intlp(n,c) = call intlpr(n,c); **  $ output integer in c colum
     280      +*  textl(s) = call textlr(s); **  $ output quoted string
     281      +*  tintl(s,i) = call tintlr(s,i); **  $ output text and integer
     282      +*  tabl(p) = call contlpr(4,p); **  $ tab to column p
     283      +*  skipl(i) = call contlpr(3, i);  **  $ skip forward i columns
     284      +*  octl(i) = call octlr(i);**  $ output octal word
     285      +*  tokl(i) = call toklr(i); **  $ list token given hash
     286      +*  endl = call endlr;**  $ end line
     287      +*  listl(n) = call contlpr(26, n); **  $ set listing flag
     288      +*  terml(n) = call contlpr(27, n); **  $ set terminal flag
     289      +*  ejectl = call contlpr(5,0); **  $ eject to new page.
     290      $   ejectlp(n) - eject new page if less than n lines left on
     291      $   current page.
     292      +*  ejectlp(n) = call contlpr(5,n); **
     293      $   macros to define macros within macros.
     294      +*  q3(a,b,c) = a b c **
     295      +*  macdef(text) = q3(+,*text*,*) **
     296      +*  macdrop(mname) = macdef(mname=) **    $  easy way to drop macr
     297
     298          $   these macros for -yes- and-no- aid readability of
     299          $   expressions involving logical variables
     300
     301      +*  yes = 1 **
     302      +*  no = 0 **
     303
     304      +*  error_notice   = '*****error**** ' **
     305      +*  system_notice  = '*system error* ' **
     306      +*  warning_notice = '****warning*** ' **
     307
dsq   23 .+s10.  $ s10 wants special characters at start of error
dsq   24          $ and warning lines.
dsq   25      +*  warn_s10 = charl(37)  **  $ per cent for warnings.
dsq   26      +*  error_s10 = charl(63) **  $ question mark for errors.
dsq   27 ..s10
dsq   28
     308      +*  hashin(i) = call hash; i = haptr; **  $ hash and get code
     309
     310
     311 $         table top increment macro
     312
     313      +*  countup(index,limit,ermsg) =
     314          index = index+1;
     315          if  (index > limit) call ltoflo(index,limit,ermsg); **
     316
     317      +*  ertoksave(iwd) =  $ macro to save token hash code
     318          lsvtk(lsvtkp+1) = iwd;  $ add to buffer
     319          lsvtkp = (lsvtkp+1).a.lsvtkz;  $ add 1 to buffer pointer (pow2
     320          lsvtk(lsvtkp+1) = 0;  $ mark end
     321          **
     322
dsq   29      $   codes for standard string sets.
dsq   30
dsq   31      +*  ss_blank =   1 **
dsq   32      $   ss_separ matches blank and other characters (such as tab and
dsq   33      $   form feed for ascii environments) which are by convention
dsq   34      $   considered equivalent to blanks.
dsq   35      +*  ss_separ =   2 **
dsq   36      +*  ss_digit =   4 **  $ digits.
dsq   37      +*  ss_ucltr =   8 **  $ upper case letters a..z
dsq   38      +*  ss_lcltr =  16 **  $ lower case letters a..z
dsq   39      +*  ss_break =  32 **  $ underline, break '_'
dsq   40
dsq   41      $   additional string sets.
dsq   42
dsq   43      +*  ss_conda =  64 **  $ string set for conditional assembly chara
dsq   44
dsq   45      $   imtoks is string of single-character (immediate) tokens. these
dsq   46      $   tokens are found efficiently by trulex without hashing.
dsq   47
dsq   48      +*  imtoks = '(),;=+-*:
^!&' **
dsq   49      +*  num_imtoks = 14 **
dsq   50 .+s66.
dsq   51      $   on s66 imtoks must be variable so can deal correctly with
dsq   52      $   both 63 and 64 character sets.
dsq   53      macdrop(imtoks)
dsq   54      +*  num_imtoks = 15 **
dsq   55 ..s66
dsq   56
dsq   57      +*  ss_immed = 128 **  $ string set for immediate token chars.
dsq   58
dsq   59      $   macros for character type (used principally by trulex).
dsq   60
dsq   61      +*  alphabetic(c) = anyc(c, ss_ucltr ! ss_lcltr ! ss_break ) **
dsq   62      +*  numeric(c) = anyc(c, ss_digit) **
dsq   63      +*  alphameric(c) = anyc(c, ss_ucltr ! ss_lcltr ! ss_break !
dsq   64          ss_digit) **
dsq   65 .+ca +*  iscachar(c) = anyc(c, ss_conda) ** $ conditional assembly.
dsq   66      $   lettercode macro maps letters in a..z_ to ordinal position and
dsq   67      $   other characters to zero. this macro used mainly to process
dsq   68      $   zzy- and zzz- symbols in macro definitions.
dsq   69      +*  lettercode(c) = ((brkc('abcdefghijklmnopqrstuvwxyz_', 1, c)
dsq   70          >= 0) * (1 + brkc('abcdefghijklmnopqrstuvwxyz_', 1, c)) ) **
dsq   71
dsq   72      $   isblank is macro to test if character is blank or equivalent
dsq   73      $   separator. blank is assumed to be only separator in upper-case
dsq   74      $   only systems (true for s37 and s66).
dsq   75
dsv   38 .-mc +*  isblank(c) = (c=1r ) **
dsv   39 .+mc +*  isblank(c) = anyc(c, ss_separ) **  $ separators.
dsq   78                                $ separators.
     330      +*  tally(i) = i = i+1; **   $ used to count things
     331      +*  digofchar(c) = $ decimal value of decimal character
     332          (c-1r0)
     333          **
     334      +*  charofdig(d) = $ character for decimal digit
     335          (d+1r0)
     336          **
     337
     338      +*  blankword =  $ machine word of blanks (cf. macro givec)
vax   30 .+s32    4r
     339 .+s37    4r
utsa  30 .+s47    4r
     340 .+s66    10r
mgfa  17 .+s10    4r
     342          **
     343
dsq   79      $   cc_tab is code for tab character if available,
dsq   80      $   or is code for blank.
dsq   81      +*  cc_tab =
dsq   82 .+s10    9
dsq   83 .+s11    9
dsq   84 .+s32    9
dsq   85 .+s37    1r
utsc   2 .+s47    9
dsq   86 .+s66    1r
dsq   87          **
dsq   88
     344
     347
     348 $            isymc(wd,j) - gets j-th char in token with ha-index wd
     349      +*  isymc(wd, j) = (.f. ws+1-cs - cs*mod((j)-1, cpw), cs,
     350              names(nameptr ha(wd) + (j-1)/cpw)) **
     351
     352
     353      +*  tokch(p, c) =  $ set first character in hashtok
     354          .f. hashtokorg -cs*(p), cs, hashtok = c;  **
     355
     356      +*  sdspack(ara,count) =  $ copy char per elm array into hashtok
     357 .-sdspack_env.
     358          size  zzza(ps);
     359          do  zzza = 1 to count;  $ loop doing each character.
     360              tokch(zzza, ara(zzza));
     361              end do;
     362          slen hashtok = count;
     363 .+sdspack_env.    $ if special code in library used.
     364          call 7nspak$li(hashtok, ara, count);
     365 ..sdspack_env
     366          **
     367
     368
     369
     370      +*  getsym(sym, hap)  = $ macro to get name as string given hash
     371          size zzza(ps);  zzza=nameptr ha(hap);  $ position word 1 of na
dsn   19 .+s10.
dsn   20 $    move characters from names into global buffer
dsn   21 $    (technique exploiting dec-10 blt byte-move ops would be helpful)
mgfa  18      .f. 5*ws+1, ws, sym = names(zzza);
mgfa  19      .f. 4*ws+1, ws, sym = names(zzza + 1);
mgfa  20      .f. 3*ws+1, ws, sym = names(zzza + 2);
mgfa  21      .f. 2*ws+1, ws, sym = names(zzza + 3);
mgfa  22      .f. 1*ws+1, ws, sym = names(zzza + 4);
dsn   26 ..s10
     372 .+s66.     $ macro is machine dependent
     373      .f. 121, 60, sym = names(zzza);   $ first part of token
     374      .f. 61, 60, sym = names(zzza+1);  $ next ten chars
     375 ..s66
vax   31 .+s32.
vax   32 $    move characters from names into global buffer
vax   33      .f. 5*ws+1, ws, sym = names(zzza);
vax   34      .f. 4*ws+1, ws, sym = names(zzza + 1);
vax   35      .f. 3*ws+1, ws, sym = names(zzza + 2);
vax   36      .f. 2*ws+1, ws, sym = names(zzza + 3);
vax   37      .f. 1*ws+1, ws, sym = names(zzza + 4);
vax   38 ..s32
     376 .+s37.
     377 $    move characters from names into global buffer
     378 $    (technique exploiting system/370 byte-move ops would be helpful)
     379      .f. 5*ws+1, ws, sym = names(zzza);
     380      .f. 4*ws+1, ws, sym = names(zzza + 1);
     381      .f. 3*ws+1, ws, sym = names(zzza + 2);
     382      .f. 2*ws+1, ws, sym = names(zzza + 3);
     383      .f. 1*ws+1, ws, sym = names(zzza + 4);
     384 ..s37
utsa  32 .+s47.
utsa  33 $    move characters from names into global buffer
utsa  34 $    (technique exploiting system/370 byte-move ops would be helpful)
utsa  35      .f. 5*ws+1, ws, sym = names(zzza);
utsa  36      .f. 4*ws+1, ws, sym = names(zzza + 1);
utsa  37      .f. 3*ws+1, ws, sym = names(zzza + 2);
utsa  38      .f. 2*ws+1, ws, sym = names(zzza + 3);
utsa  39      .f. 1*ws+1, ws, sym = names(zzza + 4);
utsa  40 ..s47
     385      size zzzl(ps);  $ for length of token
     386      zzzl = lexlen ha(hap); if  (zzzl>20) zzzl=20;
     387      slen sym = zzzl; sorg sym = sdstl+1;
     388          **
     389 $    macros used by trulex, the basic lexical scanner
     390
     391      +* keeplimit = 10 **
     392
     393
     394      +* keepc(char) =     $ macro to save char in buffer
     395 .+ct     countup(keepindex, keeplimit, 'keep');
     396 .-ct     keepindex = keepindex + 1;
     397          keep(keepindex) = char ;  **
     398
     399
     400      +* getfromkeep(char) =     $ get char from buffer
     401          char = keep(keepindex);
     402          keepindex = keepindex - 1;  **
     403 +*   givec_text(c) =  $ macro to get character
     404      if  keepindex  then  $ if prior token kept.
     405          getfromkeep(c);
     406      elseif  nowc > mccd  then  $ if new card must be read.
     407          call givecr(c);  $ read next card.
dsv   40 .+mc     c = ctpc(c);  $ fold first char in line.
     408      else
     409          if  nc10 = 1 then  $ if new word needed
     410              nowdp = nowdp + 1;  nowd = iwds(nowdp);
     411              nc10 = ws + 1;
     412              if  nowd = blankword  then  $ if blanks, take only one.
     413 .+tallytokens    tally(tallyblank)
     414                  nc10 = 1;
     415                  nowc = nowc + cpw;  $ advance to next word.
     416                  c = 1r ;
     417                  go to zzza;
     418                  end if;
     419              end if;
     420          nc10 = nc10 - cs;   $ advance to next character.
dsv   41 .+mc     c = ctpc((.f. nc10, cs, nowd));
dsv   42 .-mc     c = .f. nc10, cs, nowd;
dsq   91          nowc = nowc + 1;
     422          end if;
     423   /zzza/
     424 .+ct.
     425     if  chartrace  then  $ if tracing characters.
     426          textl(' ct=<')  charl(c) textl('> ')
     427          end if;
     428 ..ct
     429      **
     430
     431      +*  giveq(c) = givec_text(c); **  $ get character inline.
     432      +*  givec(c) = call givecp(c); **  $ get character offline.
     433
     434      +*  giveqnk(c) =   $ get character when not in -keep-.
     435      if  nowc > mccd  then  $ if new card must be read.
     436          call givecr(c);  $ read next card.
dsw   15 .+mc     c = ctpc(c);  $ convert to primary case.
     437      else
     438          if  nc10 = 1 then  $ if new word needed
     439              nowdp = nowdp + 1;  nowd = iwds(nowdp);
     440              nc10 = ws + 1;
     441              if  nowd = blankword  then  $ if blanks, take only one.
     442 .+tallytokens    tally(tallyblank)
     443                  nc10 = 1;
     444                  nowc = nowc + cpw;  $ advance to next word.
     445                  c = 1r ;
     446                  go to zzza;
     447                  end if;
     448              end if;
     449          nc10 = nc10 - cs;   $ advance to next character.
dsv   43 .+mc     c = ctpc((.f. nc10, cs, nowd));
dsv   44 .-mc     c = .f. nc10, cs, nowd;
dsq   94          nowc = nowc + 1;
     451          end if;
     452   /zzza/
     453 .+ct.
     454     if  chartrace  then  $ if tracing characters.
     455          textl(' ct=<')  charl(c) textl('> ')
     456          end if;
     457 ..ct ;
     458      **
     459      +*  givecstr(ic) =  $ get character when inside char. string
     460          call givesp(ic); **
     461
     462      +*  charin(c) =  $ add -c- to token buffer
     463          tokptr = tokptr + 1; $ advance index
     464          tok(tokptr) = c;    $ store in token array.
     465          if  tokptr > maxtoklen  then  $ check if in range
dso   10              call ermsg(10, maxtoklen, 0);  $ give error.
     467              tokptr = maxtoklen/2 + 1;  $ set to shorter token.
     468              end if;
     469          **
     470
     471 $     macro to set macro-table value
     472 .+mp.
     473      +*  seter(intoarr,value,loc) =
     474          .f. ws+1-ms - ms*mod((loc)-1, ws/ms), ms,
     475              intoarr(1 + ((loc)-1)/(ws/ms)) = value; **
     476      +*  mtset(loc,iwd) = seter(mtab,iwd,loc) **
     477
     478      +*  geter(fromarr,loc)=
     479          .f. ws+1-ms - ms*mod((loc)-1, ws/ms), ms,
     480              fromarr(1 + (loc-1)/(ws/ms)) **
     481 $     macro to get parcel from macro dictionary
     482      +*  mtget(j)=geter(mtab,j) **
     483
     484 $        macro for load into ms-bit packed vector
     485      +*  astklim = 100 **     $ dimension of -astk-
     486      +*  astkget(l) = astk(l);  **     $ gets -l- entry in astk
     487      +*  astkset(l,v) = astk(l) = v;**$ set -l-th entry in astk to v
     488
     489 $    macro to pass token to puncher routine, with check for zero arg
     490
     491      +*  mflshr(iwd) = call pflshr(iwd); **
     492
     493      +*  mcexpnd(i) =    $ get token from -mcexpand-.
     494          until  iwd;   $ loop until got non-zero token.
     495              if  keepwd then   $ see if a token was kept.
     496                  iwd = keepwd;  keepwd = 0;  $ get it if so.
     497                  quit until;   $ show got token.
     498
     499              elseif  mstkpt = 0 then   $ can call -trulex- directly.
     500                  call trulex;  $ just get token.
     501 .+tallytokens    tally(tallytrue);  $ count true tokens.
     502 .+mt.
     503                  if  mactrace then  $ if tracing macros.
     504                      textl('trulex <') tokl(iwd) textl('>') endl
     505                      end if;
     506 ..mt
     507
     508                  ertoksave(iwd);  $ save token for token list.
     509                  quit until;  $ show got token.
     510
     511              else   $ we are in a macro expansion.
     512                  call mcexpand;   $ call routine to get from macros.
     513                  end if;
     514              end until;
     515
     516          i = iwd;   $ set result token.
     517 .+mt.
     518          if  mactrace then  $ if tracing macros.
     519              textl('macexp <') tokl(iwd) textl('>') endl
     520              end if;
     521 ..mt
     522          **
     523 ..mp
     524
     525      +*  dfabsrb(i) =   $ get token from -defabsrb-.
     526 .+mp.
     527          until  iwd;  $ loop until got a token.
     528              mcexpnd(iwd);  $ first get from -mcexpand-.
     529              if  iwd = ihpl ! iwd = ihst then  $ macro start, end.
     530                  call defabsrb;   $ call routine if it is.
     531                  end if;
     532              end until;
     533
     534 .+mt.
     535          if  mactrace then  $ if tracing macros.
     536              textl('defabsrb <') tokl(iwd) textl('>') endl
     537              end if;
     538 ..mt
     539
     540 .-mp     call trulex;  $ get token if no macros.
     541
     542          i = iwd;  $ copy to output.
     543          **
     544
     545
     546 ..mp
     547 $  macros for writing token file for generator phase
     548
     549      +*  tokout1(wd) =  $ output one word token to token file
     550          tokrbufp = tokrbufp + 1; tokrbuf(tokrbufp) = wd;
     551          if  tokrbufp >=  tokrbuflim  then  $ flush buffer if full
     552              call wtrwsio(tokenfile, iorc, tokrbuf, 1, tokrbufp);
     553              tokrbufp = 0;
     554              end if;
     555          **
     556
     557      +*  tokout(hdrwd, ara, lo) =  $ output token descriptor
     558      size  zzzw(ps);  $ no of words to output
     559      size  zzzi(ps);   $ do loop index.
     560      tokout1(hdrwd);
     561      zzzw = (tokrlen hdrwd -1)/cpw + 1;
     562      if  tokrbufp+zzzw >= tokrbuflim then  $ flush buffer if full.
     563          do  zzzi = 1 to zzzw;
     564              tokout1(ara(zzzi+lo-1));
     565              end do;
     566      else
     567 .+movea_env.
     568          call 7nmova$li(tokrbuf, tokrbufp+1, ara, lo, zzzw);  $ move
     569 .-movea_env.
     570          do  zzzi = 1 to zzzw;  $ just copy into buffer.
     571              tokrbuf(tokrbufp+zzzi) = ara(lo-1+zzzi);  $ copy one word.
     572              end do;
     573 ..movea_env
     574          tokrbufp = tokrbufp+zzzw;
     575          end if;  **
     576
       1 .=member start
dsn   27 .+s10  prog start;
vax   39 .+s32  prog start;
dsn   28 .+s37  prog start;
utsa  41 .+s47  prog start;
dsn   29 .+s66  subr start;
       4 $    all global variables are defined in this routine.
       5 $    the routine lexini is called to perform needed initializations
       6 $    and then lexdo, the driver for the scanner, is called.
       7 .+s66    nameset blank;      $  keep in blank common on s66.
       8      size  astk(ps); dims astk(astklim);  $ stack for macro arguments
       9 .+s66    end nameset blank;
      10      size  astkpt(ps); data astkpt=0; $ top of macro arg. list
      11      size  bugtoks(ps);  dims bugtoks(numbugtoks);
      12      size  caname(cs); dims caname(mccd-3);  $ ca name
      13      size  cardlisted(1);  $ flag set when card listed
      14      size  cardsent(1);  data cardsent = yes;  $ 'card sent to gen'
      15      size  col3char(cs);  $ column 3 of card
      16      size  canamel(ps);  $ length of -caname-
      17      size  cardskip (1); data cardskip=0; $ card'skip flag
      19      size  chartrace(ps);  $ char trace flag
      20      size  countzzy(ps); dims countzzy(27); data countzzy = 0(27);
      21      size  countzzz(ps); dims countzzz(27); data countzzz = 0(27);
      22 .+cr.
      23      size  crfilename(sds(filenamelen));  $ name of reference file.
      24      size  crfileparm(sds(filenamelen));  $ skeleton for ref. file name
      25      size  crbuffptr(ps);  data crbuffptr = 0;
      26 .+s66    nameset blank;      $  keep in blank common on s66.
      27      size  crbuff(ws);  dims crbuff(crbuffmax);
      28 .+s66    end nameset blank;
      29      size  creftot(ps);  data creftot = 0;  $ total number of refs.
      30 ..cr
      31      size  dodetect(1);    $ on to list suspicious variables.
      32      size  errecho(1);  data errecho = no;  $ for error echo of input c
      33      size  exitcode(1); data exitcode = yes;  $ exit code for -lexexit-
      34      size  fivdecara(cs);  dims fivdecara(5); $ fivdec result.
      35 .+cr size  crefent(ws);  $ cross reference entry.
      36      size  haptr(ps);        $ index of current ha entry.
      37 .+s66    nameset blank;      $  keep in blank common on s66.
      38      size  ha(hasz);dims ha(hadim); $ symbol table.
      39 .+s66    end nameset blank;
      40      size  hafree(ps);  data hafree = hadim+1;  $ free pointer for hash
      41      size  hashca(ps);  $ hash-code of -caname-
      42 .+ca size  hashcaset(ps); $ hash code of -set-
      43      size  hashlen(ps);  $  length in chars of token to hash
      44      size  hashtok(hashtokorg-1); data hashtok=0; $ global hash input s
      45      size  hashtrace(ps);  $ hashtrace flag
      46      size  hashtyp(ps);  $ lexical typeof hashed token
      47      size  hashwords(ps);  $ no of words in hashed token
      48      size  haused(ps); data haused=0; $ no of ha-words full
      49      size  icdno(ps); data icdno=0; $ no. of cards read
      50      size  icdlast(ps); data icdlast = 0;  $ last card no. sent to gen.
      51      size  ihcm(ps);  $ hash-index of symbol ',' (comma)
      52      size  ihcompdate(ps);  $ ha index of compilation date.
      53      size  iheq(ps);  $  hash pointer for symbol -=-
      54      size  ihlp(ps);  $ hash-index of symbol '(' (left paren)
      55      size  ihpl(ps);  $ hash-index of symbol '+' (plus)
      56      size  ihpr(ps);
      57      size  ihrp(ps);  $ hash-index of symbol ')' (right paren)
      58      size  ihsemi(ps);  $ hash-code of semicolon
      59      size  ihsl(ps);  $ hash-code of slash /
      60      size  ihst(ps);  $ hash-index of symbol '*' (star)
dsq   95      size  imtoktab(ps);  dims  imtoktab(num_imtoks);
dsq   96 .+s66.
dsq   97      $   imtoks is variable so can deal with 63 and 64 sets.
dsq   98      $   see lexini for details.
dsq   99      size  imtoks(.sds. num_imtoks);
dsq  100      data  imtoks = '(),;=+-*
^!&::' ;
dsq  101 ..s66
      62      size  initializing(1); data initializing=yes;
      63          $ -initializing- on while we are initializing the scanner.
      64      size  initloc(ps);  $ used to save -prevloc-
      65 .+cr   size  isonxrf(ps);  data isonxrf = no;  $ on when doing xref
      66      size  iorc(ps);  $ return code from io operation.
      67      size  iwd(ps);  $  ha-index
      68      size  iwds(ws); dims iwds(wpc); $ input card image
      69      size  keep(cs);  dims keep(keeplimit);$ character buffer for givec
      70      size  keepindex(ps);      data keepindex = 0;    $ index into keep
      71      size  keepwd(ps);  data keepwd=0;  $ one-token buffer
      72      size  lastwd(ps);   $ index of last non-blank word on card.
      73      size  lcp_opt(1); data lcp_opt=yes; $ on to list parameters.
      74      size  lcs_opt(1); data lcs_opt=yes; $ on to list statistics.
      75      size  lelvalue(ps);  $ error limit.
      78      size  lexdotrace(ps); data lexdotrace = 0; $ lexdo tok list
      79      size  listapt(ps); data listapt=0; $ no. of args in current macro
      80      size  listarg(ps);  dims listarg(listarglim);
      81      $   listignore is set when .=list directives are to be ignored.
      82      size  listignore(1); data listignore = no;
      83
      84      $   listprev is list of prior list control status entries.
      85      size  listprev(ps);  dims listprev(listprevmax);
      86      size  listprevptr(ps);  data listprevptr = 1;
      87      size  listnow(ps);      $ current list status word.
      88      size  listnew(ps);      $ new list status word.
      89      size  listvals(ps);  $ array of list parameters
      90      +*  list_code        =  1 **  $ list generated code in -asm-
      91      +*  list_input       =  2 **  $ list input in -gen-
      92      +*  list_autotitle   =  3 **  $ auto titling in -gen-
      93      +*  list_skip        =  4 **  $ list skipped cards
      94      +*  list_qualifiers  =  5 **  $ list conditional qualifiers
      95      +*  list_linput      =  6 **  $ list input in -lex-
      96      +*  list_references  =  7 **  $ collect references
      97      +*  list_definitions =  8 **  $ punch macro definitions
      98      +*  list_expansions  =  9 **  $ punch expanded text
      99      +*  list_resume      = 10 **  $ pop listing stack
     100      +*  list_directive   = 11 **  $ list current list directive
     101
     102      +*  listinginput   = .f. list_linput,     1, listnow **
     103      +*  collectingrefs = .f. list_references, 1, listnow **
     104      +*  listingen = .f. list_input, 1, listnow **
     105
     106      +*  numlistparms = 11 **  $ number of listing options
     107      dims  listvals(numlistparms);
     108
     109      $   definitions of fields of -listvals-
     110      +*  listval_tf = .f. 1, 1, **  $ output data to token file
     111      +*  listval_ll = .f. 2, 1, **  $ causes directive to list in -lex-
     112      +*  listval_gl = .f. 3, 1, **  $ causes directive to list in -gen-
     113      +*  listval_df = .f. 4, 1, **  $ default initial value
     114
     115      $   array of characters used in 'list' parameter
     116      size  listchars(cs); dims listchars(numlistparms);
     117
     118      +*  setlist(val, char, tf, ll, gl, df) =  $ macro to set option
     119          listchars(val) = char:
     120          listvals(val) = 8*df + 4*gl + 2*ll + tf **
     121
     122      data    $ initialize list control arrays
     123
     124 $                    value          ic   tf   ll   gl   df
     125          setlist(list_code,        1rc, yes, yes, yes,  no):
     126          setlist(list_input,       1ri, yes, yes, no,   no):
     127          setlist(list_autotitle,   1ra, yes, yes, yes,  no):
     128          setlist(list_skip,        1rs, no,  yes, yes,  no):
     129          setlist(list_qualifiers,  1rq, no,  yes, yes,  no):
     130          setlist(list_linput,      1rl, no,  no,  yes,  no):
     131          setlist(list_references,  1rr, no,  yes, yes, yes):
     132          setlist(list_definitions, 1rd, no,  yes, yes,  no):
     133          setlist(list_expansions,  1re, no,  yes, yes,  no):
     134          setlist(list_resume,      0,   no,  no,  no,   no):
     135          setlist(list_directive,   0,   no,  no,  no,   no);
     136
     137      macdrop(setlist)
     138      size  lsvtk(ps); dims lsvtk(lsvtkz+1); data lsvtk = 0(lsvtkz+1);
     139      size  lsvtkp(ps); data lsvtkp=0; $ current entry in lsvtk
dst   11 .+mdc.
     140      size  mdclist(ps);  data mdclist=no;  $ on to list mach. dep. cnst
dst   12 ..mdc
     141      size  mstk(ws); dims mstk(mstklim);  $ macro expansion control
     142 .+mp. $ variables used in mcacroprocessor
     143      size  mactrace(1);  data mactrace=no;  $ on for macro trace
     144      size  mname(ps);  $ ha index of macro name.
     145      size  mstkpt(ps); data mstkpt=0; $ top of macro control stack
     146      size  mtptr(ps); data mtptr=0; $ top of macro def. table
     147 .+s66    nameset blank;      $  keep in blank common on s66.
     148      size  mtab(ws); dims mtab(mtlim/(ws/ms)); $ macro table
     149 .+s66    end nameset blank;
     150 ..mp
     151 .+s66    nameset blank;      $  keep in blank common on s66.
     152      size  names(ws);  dims names(namesmax);
     153 .+s66    end nameset blank;
     154      size  nc10(ps);         $ position in current word nowd
     155      size  nerrors(ps); data nerrors=0;  $ number of detected errors.
     156
     157      size  normwork(5);  $ normal work to do for a card
     158      $   this is needed by -givecr- to determine what processing
     159      $   is needed for each card.  the flags in the variable
     160      $   indicate the following types of processing:
     161      +*  proc_work = 1b'10001' **  $ have -lex- process card
     162      +*  list_work = 1b'10010' **  $ have -lex- list card
     163      +*  elim_work = 1b'10100' **  $ eliminate qualifiers fro card
     164      +*  out_work  = 1b'11000' **  $ send card to -gen- to list
     165
     166      data  normwork = out_work!proc_work;
     167
     168      size  nowc(ps); data nowc=mccd+1; $ last column of input processed
     169      size  nowd(ws);  $ current word in iwd
     170      size  nowdp(ps);  $     $ idex in iwds of current word
     171      size  nparen(ps);  $ number of parens seen in macro argument
     172      size  namesptr(ps); data namesptr=1; $ next free word in names
     173      size  numargs(ps);  $ number of macro arguments
     174      size  nwarnings(ps); data nwarnings=0; $ warning count.
     175      $   punchdefine on to punch macro definitions; punchexpand on
     176      $   punch expanded text.
     177      size  punchdefine(1);  data punchdefine = no;
     178      size  punchexpand(1);  data punchexpand = no;
     179      size  punchfilename(sds(filenamelen));  $ name of punch file
     180      size  punchopened(1); data punchopened=no; $ on when pun file open
     181      size  punchpos(ps); data punchpos=0; $ position in punch buffer
     182      size  punchbuf(cs);  dims punchbuf(80);  $ punch line.
     183      size  punhold1(ps), punhold2(ps);  $ keept tokens.
     184      size  punlastlt(ps);  $ last lexical type for punch.
     185 .+bub.
     186      size  res(ps); dims res(reslim);  $ token backup buffer (for pa
     187      size  resptr(ps); data resptr=0;  $ top of (unused) token back
     188 ..bub
     189      size  subtitling(1); data subtitling=no;  $ on when doing subtitle
     190 .+tallycomments.  $ counters for optional comment statistics
     191      /*  these statistics count the number and type of comments.
     192          they are included in the production compiler as they provide
     193          a rough measure of documentation quality. */
     194      size  tallypl1(ps); data tallypl1=0; $ no. of pl/1 comments
     195      size  tallyeol(ps); data tallyeol=0; $ number of $-style comments
     196 ..tallycomments
     197 .+tallytokens.  $ counters for optional token statistics
     198      /*  the token statistics count the number of immediate tokens,
     199          the number of tokens found by the scanner, and the number of
     200          tokens sent to the parser.*/
     201      size  tallytrue(ps); data tallytrue=0; $ number of true tokens
     202      size  tallyimtok(ps); data tallyimtok=0; $ immediate tokens
     203      size  tallyparse(ps); data tallyparse=0; $ tokens to parser
     204      size  tallyblank(ps); data tallyblank=0; $ blank words seen
     205 ..tallytokens
     206 .+tallyhash.  $ counters for optional hash statistics
     207      /*  the hash statistics count the number of times the symbol
     208          table is searched, and the number of entries examined. */
     209      size  tally_haprobes(ps); data tally_haprobes=0; $ number of probe
     210      size  tally_haentries(ps); data tally_haentries=0; $ number of ent
     211      size  tally_halinks(ps);   data tally_halinks = 0; $ number of lin
     212 ..tallyhash
     213      size  termlex(ps);  $ on to terminate after lexical phase.
     214      size  tok(cs); dims tok(maxtoklen+1);  $ token array
     215      size  tokptr(ps);  $ current entry in token buffer
     216 .+s66    nameset blank;      $  keep in blank common on s66.
     217      size  tokrbuf(ws);  dims tokrbuf(tokrbuflim);
     218 .+s66    end nameset blank;
     219      size  tokrbufp(ps);  data tokrbufp=0;  $ index of last token outpu
     220      size  tokrwd(ws); $ for outputting token descriptor
     221      size  toktrace(ps); data toktrace=no; $ on for -trulex- -ha- trace
     222      size  tokwrt(1); $ switch on when writing token file
     223      size  tokenfilename(sds(filenamelen)); $ name of token file
     224
     225      call lexini;
     226      call lexdo;  $ main driver routine for scanner
     227      exitcode = 0; call lexexit;  $ terminate scan
     228
dsn   30 .+s10  end prog start;
vax   40 .+s32  end prog start;
dsn   31 .+s37  end prog start;
utsa  42 .+s47  end prog start;
dsn   32 .+s66  end subr start;
       1 .=member lexini
       2      subr lexini;  $  initialization
       3 $    lexini is initialization routine, called only once from start.
       4 $    lexini initializes variables, processes the control-card
       5 $    options for the scan, and prints the initial part
       6 $    of the header on the scanner output file.
       7
       8      size  c(cs);  $ temporary for character table set up
       9      size  tmparm(sds(filenamelen));  $ target machine parameter.
      10 .+ca    size  inisetparm(sds(filenamelen));  $ initial set request.
      11      size  lstimestr(.sds. lstimelen);
      13      size  i(ps), j(ps), l(ps);  $ loop indices
      14      size  inimemname(.sds. filenamelen);  $ name of initial member.
      15      size  ilp(.sds. filenamelen);  $ initial list parameter.
      16      size  tokrwd(ws);       $ for writing list control on token file.
      17      size  liststr(sds(1));  $ used to process -list- parameter
dsq  102      size  updseq(ps);       $ upd sequence option.
dsq  103      size  brkc(ws);      $ function to locate character in string.
dsr   15      size  appstr(.sds. getapp_len);  $ actual parameter string.
      18 .+s66    size  ha_00b(ps);  $ hash code for character 3b'00'.
      19 .+s66    size  ha_63b(ps);  $ hash code for character 3b'63'.
      20
      21      do  i = 1 to hadim;  ha(i) = 0;  end do;  $ clear the ha.
      22
dsq  104      call blds('+-.', ss_conda); $ string set for conditional assembly
      50
      51      sorg hashtok = hashtokorg;  $ origin will never be changed
      52
      53      $   get name in initial member to include.
      54      call getspp(inimemname, 'imem=/');
      55
vax   41 .+s32    call getspp(tokenfilename,'tokens=tokens.tmp/');
      56 .+s37    call getspp(tokenfilename,'tokens=sysut1/');
utsa  43 .+s47    call getspp(tokenfilename,'tokens=sysut1/');
      57 .+s66    call getspp(tokenfilename,'tokens=tokens/');
mgfa  23 .+s10    call getspp(tokenfilename, 'tokens=*.tok/');
      59
      60      tokwrt = (.ch. 1,tokenfilename ^=1r0); $ on if writing tokens
      61 $    tokwrt is now zero if not writing token file; otherwise
      62 $    is name of token file
      63      call opensio(tokenfile, iorc, access_write, tokenfilename,
      64          tokrbuflim*cpw, i, 0, 0);
dsr   16 .+s66  call rewisio(tokenfile, iorc, 0);
vax   42 .+s32    call getspp(punchfilename, 'pfn=little.pun/');
      66 .+s37    call getspp(punchfilename, 'pfn=syspunch/');
utsa  44 .+s47    call getspp(punchfilename, 'pfn=syspunch/');
      67 .+s66    call getspp(punchfilename, 'pfn=lexout/');
      68 .+s10    call getspp(punchfilename, 'pfn=*.pun/');
      69
      74
      75 $  param -lt- used to get token list in -lexdo- set initial value
      76      call getipp(lexdotrace, 'lt=0/1');
      77 .+ct call getipp(chartrace, 'ct=0/1');
      78 .+ht call getipp(hashtrace, 'ht=0/1');
      79 .+mt call getipp(mactrace, 'mt=0/1');
      80
      81 .+cr.
vax   44 .+s32    call getspp(crfileparm, 'rf=little.rf0/');
      82 .+s37    call getspp(crfileparm, 'rf=sysref(ref0)/');
utsa  45 .+s47    call getspp(crfileparm, 'rf=sysref(ref0)/');
      83 .+s66    call getspp(crfileparm, 'rf=ref0/');
dsn   33 .+s10    call getspp(crfileparm, 'rf=*.rf0/');
      85      call getipp(isonxrf, 'lcr=0/1');
      86      if  isonxrf  then
      87          call crfnam(crfilename, crfileparm, 1);
      88          call opensio(crfile, iorc, access_write, crfilename,
      89              0, i, 0, 0);
      90          creftot = 0;
      91          end if;
      92 ..cr
      93
dsz   12      call getipp(dodetect, 'susp=0/0');
dst   13 .+mdc.
      95      call getipp(mdclist, 'mdc=0/1');
dst   14 ..mdc
      96
      97      call getipp(lelvalue, 'lel=25/');
      98      $   scan aborted if more than lelvalue errors detected.
      99
     100      $   lcp_opt gives parameter list if on; lcs_opt lists statistics.
     101      call getipp(lcp_opt, 'lcp=1/0');
     102      call getipp(lcs_opt, 'lcs=1/0');
utsb  17 .+s32u.  $ minimal listing by default for unix.
dsv   46      call getipp(lcp_opt, 'lcp=0/1');
dsv   47      call getipp(lcs_opt, 'lcs=0/1');
utsb  18 ..s32u
utsb  19 .+s47.  $ minimal listing by default for unix.
utsb  20      call getipp(lcp_opt, 'lcp=0/1');
utsb  21      call getipp(lcs_opt, 'lcs=0/1');
utsb  22 ..s47
     103
     104      listnow = 0;  listnew = 0;  $ clear values
     105
     106      call getspp(ilp, 'list=sq/isqa');
     107
dsq  105      call getipp(updseq, 'upd=0/1');  $ upd sequence option
dsq  106
     108      sorg liststr = sds(1)+1; slen liststr = 1; $ initialize string
     109      do  i = 1 to numlistparms;  $ process each parm
     110          .f. i, 1, listnow = listval_df listvals(i);  $ set default
     111          .f. i, 1, listnew = listval_df listvals(i);
     112          c = listchars(i); $ get character
     113          if  c then  $ use value given
     114              .ch. 1, liststr = c;  $ build into sds
     115              if  (liststr .in. ilp) .f. i, 1, listnew = yes;
     116              end if;
     117          end do;
     118
     119      listprev(1) = listnow;  $ set prior options
     120      listnow = listnow .ex. listnew;  $ flag changed options
     121
     122      do  i = 1 to numlistparms; $ process changes
     123          if  (.f. i, 1, listnow = no) cont do;  $ not changed
     124          if  listval_tf listvals(i) & tokwrt then  $ write to token fil
     125              tokrwd = 0;
     126              tokrtyp tokrwd = listcontroltok;
     127              tokrlen tokrwd = i;  $ set list parameter number
     128              tokrlc  tokrwd = .f. i, 1, listnew;  $ set value
     129              tokout1(tokrwd);
     130              end if;
     131          end do;
     132
     133      listnow = listnew;  $ set active listing mode
     134      if  ('0' .in. ilp) listignore = yes;
     135      punchdefine = .f. list_definitions, 1, listnow;
     136      punchexpand = .f. list_expansions,  1, listnow;
     137      if  (listinginput) normwork = normwork ! list_work;
vax   45 .+s32    call getspp(tmparm, 'tm=32/');
     138 .+s37    call getspp(tmparm, 'tm=37/');
utsa  46 .+s47    call getspp(tmparm, 'tm=47/');
     139 .+s10    call getspp(tmparm, 'tm=10/');
     140 .+s66    call getspp(tmparm, 'tm=66/');
     141
     142 .+ca.
     143      call getspp(inisetparm, 'iset=/');
     144 ..ca
     145
     146      call getipp(termlex, 'termlex=0/1');
dsr   17
dsr   18      $   get actual parameters specified.
dsr   19      call getapp(appstr, getapp_len);
dsr   20
     147      $   set up listing title, get compilation date.
     148      call ltitlr(scannerlevel);
     149      call stitlr(0, 'little compilation - lexical scan phase.');
     150
     151      call lstime(lstimestr);
     152
     153      if  (lcp_opt=0) go to parmslisted;
     154
     155      call stitlr(1, 'parameters for lexical scan.');
dsr   21
dsr   22      if  .len. appstr  then $ if any explicitly specified.
dsr   23          textl(appstr)  endl endl
dsr   24          end if;
dsr   25
     160      if  slen inimemname  then  $ if including initial member.
     161          textl('initial member to include: imem = ')
     162          textl(inimemname)  charl(1r.)  endl
     163          end if;
     164      if  slen ilp then  $ if list parameters specified
     165          textl('initial list options: list = ') textl(ilp)
     166          textl('.') endl
     167          end if;
     168      textl('token file: tokens = ') textl(tokenfilename)
     169      textl('.  punch file: pfn = ') textl(punchfilename)
     170      textl('.') endl
     171
     172      textl('list statistics: lcs =') intlp(lcs_opt,2)
     173      textl('.  list suspicious names: susp =')  intlp(dodetect, 2)
     174      textl('.')  endl
     175      textl('lexical error limit: lel =') intl(lelvalue)
dsq  107      textl('.  upd sequence: upd =') intlp(updseq, 2)
     176      textl('.') endl
     177 .+cr.
     178      textl('lexical cross reference list: lcr =')  intlp(isonxrf,2)
     179      textl('.  reference file: rf = ')  textl(crfileparm) textl('.')
     180      endl
     181 ..cr
     182 .+ca.
     183      endl  textl('conditional inclusion selected for symbol')
     184      if  slen inisetparm  then
     185          textl('s:  ')
     186          textl(inisetparm)
     187      else
     188          textl(':')
     189          end if;
     190      textl('   s') textl(tmparm)
utsb  23 .+s32u  textl('  s32u')
     191      endl
     192 ..ca
     193      endl  endl
     194 /parmslisted/
     195
     196 $        initialize table for detecting special period delim tokens
     197      +* lextokstr =
     198'chtr nochtr hatr nohatr lextr nolextr mactr nomactr compdate '
     199     **
     200      hashtyp = optok;  $ type remains fixed for all used of bughash
     201      tokch(1, 1r.);  j = 0;  l = 1;
     202      do  i = 1 to slen lextokstr;
     203          c = .ch. i, lextokstr;
     204          if  c=1r  then  $ if end of current
     205              l = l+1; tokch(l, 1r.);
     206              slen hashtok = l;
     207              hashin(l);  j = j + 1; bugtoks(j) = l;
     208              l = 1;
     209          else  $ add character to current literal
     210              l = l+1; tokch(l, c);
     211              end if;
     212          end do;
     213      macdrop(lextokstr)
     214
     215 $    initialize one-character special token table
     217      slen hashtok = 1;  $ all immediate tokens are 1 char
     218      hashtyp = spectok;  $ and are special
     219
dsq  108      do  i = 1 to num_imtoks;
dsq  109          c = .ch. i, imtoks;
     222          tokch(1, c);  $ enter into hashtok
     223          hashin(haptr);
dsq  110          imtoktab(1+brkc(imtoks, 1, c)) = haptr;
dsq  111          end do;
dsq  112
dsq  113 .+s66.
dsq  114      $   for s66, initialize so both codes 3b'00' and 3b'63' accepted
dsq  115      $   as little colon.
dsq  116      .ch. 14, imtoks = 3b'63';
dsq  117      tokch(1, 3b'63'); hashin(ha_63b); imtoktab(14) = ha_63b;
dsq  118      .ch. 15, imtoks = 3b'00';
dsq  119      tokch(1, 3b'00'); hashin(ha_00b); imtoktab(15) = ha_00b;
dsq  120 ..s66
dsq  121
dsq  122      call blds(imtoks, ss_immed); $ string set for immediate tokens
     230 .+ca.
     231 $    hash in name -set- for use by conditional-assemblyfeature
     232
     233      tokch(1,1rs); tokch(2,1re); tokch(3,1rt);
     234      slen hashtok = 3;  hashtyp = nametok;
     235      hashin(hashcaset);  $ put hashcode in -hashcaset-
     236      $   generate set corresponding to target machine.
     237      tokch(2, (.ch. 1, tmparm));
     238      tokch(3, (.ch. 2, tmparm));
     239      hashin(i);
     240      cab ha(i) = yes;
     241      nuses ha(i) = suspi+1;  $ avoid listing as suspicious.
utsb  24 .+s32u.  $ if compiling in s32u, define symbol 's32u'.
utsb  25      tokch(1,1rs); tokch(2,1r3); tokch(3,1r2); tokch(4,1ru);
dsx   13      slen hashtok = 4;
dsx   14      hashin(i); cab ha(i) = yes; nuses ha(i) = suspi+1;
utsb  26 ..s32u
     242 ..ca
     243
     244      $   build string with compilation date for .compdate. value.
     245      slen hashtok = lstimelen;
     246      do  i = 1 to lstimelen;
     247          tokch(i, (.ch. i,lstimestr));
     248          end do;
     249      hashtyp = stringtok;
     250      hashin(ihcompdate);
     251
     252      hashtyp = spectok;
     253 +*   inihash(var, sym) =
     254      slen hashtok = slen sym;  $ set length in characters for hash
     255      do  i = 1 to slen sym;  tokch(i, (.ch. i, sym));  end do;
     256 .+ht.
     257      if  hashtrace  then
     258      textl('inihash -') textl(sym) charl(1r )
     259          tintl(' type',hashtyp)  endl   end if;
     260 ..ht
     261      hashin(var); **
     262
dsq  123      ihlp = imtoktab(1+brkc(imtoks, 1, 1r( ));
dsq  124      ihrp = imtoktab(1+brkc(imtoks, 1, 1r) ));
dsq  125      ihpl = imtoktab(1+brkc(imtoks, 1, 1r+ ));
dsq  126      ihst = imtoktab(1+brkc(imtoks, 1, 1r* ));
dsq  127      ihcm = imtoktab(1+brkc(imtoks, 1, 1r, ));
dsq  128      ihsemi = imtoktab(1+brkc(imtoks, 1, 1r; ));
dsq  129      iheq = imtoktab(1+brkc(imtoks, 1, 1r= ));
     267      inihash(ihsl, '/');  inihash(ihpr, '.');
     268
     269      hashtyp = nametok;
     270      call setlit;            $ routine to set literal codes
     271
     272 .+s66  litcod ha(ha_63b) = 70;  $ set literal code for colon.
     273 .+s66  litcod ha(ha_00b) = 70;  $ set literal code for colon.
     274 .+ca  nuses ha(hashcaset) = suspi + 1;
     275 .+ca.
     276      $   if initial set requested, set conditional bit for name.
     277      if  slen inisetparm  then
dsy   11           call cainit(inisetparm);
     281          end if;
     282 ..ca
     283      initializing = no;  $ indicate termination of initialization
     284      call stitlr(1, 'program listing (lexical phase)');
     285
dsq  130      call opninc('', inimemname, '', updseq); $ open input file.
     287
     288      macdrop(inihash);      $  drop -inihash- macro
     289      end subr lexini;
       1 .=member cainit
       2 .+ca.
       3       subr cainit(iparm);
       4
       5 $     initialize iset parameter string, which consists of names
       6 $     separated by plus sign characters with optional
       7 $     plus sign before first name.
       8
       9       size iparm(.sds. filenamelen);
      10       size  plen(ps);           $ length of parm string
      11       size  inow(ws);           $ current position
      12       size  ilen(ws);           $ length of current part.
      13       size  cnow(cs);           $ current character
      14       size  i(ws);              $ ha index.
      15       size  anyc(ws), brkc(ws); $ string search functions.
      16
      17       plen = .len. iparm;
      18       if  (plen = 0)  return; $ quit if null string.
      19
      20       inow = 1;
      21
      22       while inow <= plen;  $ loop over string
      23           cnow = .ch. inow, iparm;  $ get current character.
      24           if  cnow = 1r+  then $ if sign char.
      25               inow = inow + 1;  $ advance to next character
      26               cont while;
      27               end if;
      28           ilen = brkc(iparm, inow, 1r+); $ look for next plus
      29           hashtyp = nametok; $ assume name.
      30           if  ilen<0  then  $ if none, name is rest
      31               ilen = plen - inow + 1;
      32               end if;
      33           if alphabetic(cnow) = no then  $ error
      34               call ermsg(5,cnow,0); $ check error number
      35           else
      36               do  i = 1 to ilen;
      37                   cnow = .ch. (inow+i-1), iparm; $ next char.
      38                   if alphameric(cnow) = no then $ error
      39                       hashtyp = 0; $ indicate illegal.
      40                       quit do;
      41                       end if;
      42                   tokch(i, cnow);
      43                   end do;
      44               if hashtyp = 0 then  $ if illformed token
      45                   call ermsg(5, cnow, 0);
      46               else
      47                   slen hashtok = ilen;
      48                   hashin(i);
      49                   cab ha(i) = yes;
      50                   end if;
      51               end if;
      52           inow = inow + ilen;
      53           end while;
      54        end subr cainit;
      55 ..ca
       1 .=member setlit
       2      subr setlit;
       3      +* il(s) = call inslit(s); **
       4
       5      /*  literal strings and their literal numbers are encoded as
       6      described below in -inslit-. */
       7
       8
       9 $    note that the following mapping is identical to macro definitions
      10 $    in gen and any change  or addition must also be made in gen.
      11
      12      hashtyp = nametok;
      13
      14 il('1 if + while + until + do + end + else + size + dims + data ')
      15
      16 il('11 nameset + access + real + call + goby + return + elseif ')
      17
      18 il('18 in 21 rewind + filestat + go + cont + quit 32 to ')
      19
      20 il('59 check + trace + assert + nocheck + notrace + subr + fnct ')
      21
      22 il('66 monitor 71 then + by + index + flow + stores + entry ')
      23
      24 il('80 file 85 get + put 92 limit + read + write + prog ')
      25
      26      hashtyp = spectok;      $ special symbols
      27
      28 il('10 ; 36 ! 38 & 46 = 47 < + > + ^ + + + - + * + / ')
      29
      30 il('67 ( + ) + , + : ')
      31
      32      hashtyp = optok;
      33
      34 il('19 .sds. + .voapart. ')
      35
      36 il('26 .f. + .e. + .s. + .ch. 31 .cc. 33 .or. + .ex. + .exor. ')
      37
      38 il('37 .and. 39 .a. + .eq. + .ne. + .gt. + .lt. + .ge. + .le. ')
      39
      40 il('54 .in. + .not. + .n. + .fb. + .nb. ')
      41
      42 il('77 .voadump. + .len. + .pad. ')
      43
      44 il('81 .nocontr. + .toktr. + .notoktr. + .contr. ')
      45
      46 il('87 .ws. + .ps. + .cs. + .sl. + .so. 96 .seq. + .sne. ')
      47
      48      macdrop(il)
      49
      50      end subr setlit;
       1 .=member inslit
       2      subr inslit(s);  $ insert literal in hash table
       3      $ called by macro -il- to set literal code in ha for all
       4      $ keywords and literal
       5
       6      size  s(sds(70));  $ literal to hash
       7      size  litlc(ps);   $ literal code to set
       8      size  i(ps);             $ hash index of lit
       9      size  l(ps);     $ length of literal
      10      size  c(cs);       $ current character
      11      size  state(ps);     $ current state during scan
      12
      13      /* s is an encoding of literal numbers and corresponding literals.
      14      entries alternate between numerics and literals; numerics
      15      give the literal numbers (a + indicates that literal
      16      number is to be incremented).  fields are separated by one or more
      17      blanks.  the first field is a number, the last character must be
      18      blank.  */
      19
      20      state = 1;  $ begin with search for numeric
      21      litlc = 0;  $ literal code to set
      22
      23      do  i = 1 to slen s;
      24          c = .ch. i, s;  $ current character
      25          go to st(state) in 1 to 4;
      26      /st(1)/  $ skip blanks to start of numeric field
      27          if  (c=1r ) cont do;
      28          if  c = 1r+  then litlc = litlc + 1; state = 3;
      29          else
      30              litlc = digofchar(c); state = 2; end if;
      31          cont do;
      32      /st(2)/  $ collect numerics up to blanks
      33          if  (c=1r )  then  state = 3;
      34          else litlc = 10*litlc + digofchar(c); end if;
      35          cont do;
      36      /st(3)/  $ skip blanks to start of literal
      37          if  (c=1r ) cont do;
      38          l = 0;   state = 4;  $ start literal
      39          $ fall through to st(4) to get first character
      40      /st(4)/  $ add non-blanks to literal
      41          if  c=1r   then
      42              slen hashtok = l;  $ set length of literal
      43              hashin(l);  $ hash in, set hash code to l
      44              litcod ha(l) = litlc;  $ set literal code
      45              state = 1;
      46          else
      47              l = l+1; tokch(l, c); $ add character to literal
      48              end if;
      49          end do;
      50
      51      end subr inslit;
       1 .=member lexdo
       2      subr lexdo;  $  control routine - gets tokens and writes them out
       3 $    -lexdo- is main driver routine for scanner
       4 $    the initialisation routine -lexini- is called.
       5 $    tokens are then obtained from -nextw- and written
       6      size  i(ps);   $ temporary.
dsq  131      size  anyc(ws);   $ any string search function.
dsq  132      size  brkc(ws);   $ break string search function.
       7
       8  while  yes;  $ loop forever.
       9      while  yes;  $ loop until got a token.
      10 .+bub.
      11          if  rptr < resptr then  $ get from backup table.
      12              rptr = rptr+1;  iwd = res(rptr);  $ get token index.
      13              quit while;  $ show token obtained.
      14              end if;
      15 ..bub
      16
      17          dfabsrb(iwd);  $ get token from below.
      18          while  macimm ha(iwd);  $ process immediate macros.
      19              iwd = macorg ha(iwd);  $ get new token.
      20              end while;
      21
      22          $   now see if this token is a normal macro.
      23          if  macorg ha(iwd) then  $ it is a macro.
      24              call nextw;  $ call routine to start expansion.
      25              cont while;  $ go get next token.
      26              end if;
      27
      28          until  yes;  $ now check for zzz or zzy tokens.
      29              if  (lexlen ha(iwd) ^= 4) quit until;  $ not if length 4.
      30              if  (lextyp ha(iwd) ^= nametok) quit until;  $ not name.
      31              if  (.f. ws+1-2*cs, 2*cs, names(nameptr ha(iwd)) ^= 2rzz)
      32                  quit until;  $ first two characters not zz.
      33              i=lettercode((.f. ws+1-4*cs, cs, names(nameptr ha(iwd))));
      34              if  (i=0) quit until;  $ not letter *** assumes cpw>=4 ***
      35              if  .f. ws+1-3*cs, cs, names(nameptr ha(iwd)) = 1ry !
      36                  .f. ws+1-3*cs, cs, names(nameptr ha(iwd)) = 1rz then
      37                  call buildz(iwd, i, nametok + (dectok-nametok) *
      38                      (.f. ws+1-3*cs,cs,names(nameptr ha(iwd))=1ry));
      39                  end if;
      40              end until;
      41
      42          quit while;  $ show got token.
      43          end while;
      44
      45 .+bub.
      46      resptr = resptr+1;  res(resptr) = iwd;  $ save in backup buffer.
      47      rptr = resptr;  $ set pointer.
      48      if  resptr >= reslim then  $ this is a full buffer.
      49          do  i = 1 to reslim/2;  $ move down contents.
      50              res(i) = res(i + reslim/2);  $ move each entry.
      51              end do;
      52
      53          resptr = reslim/2;  rptr = resptr;  $ set new pointer.
      54          end if;
      55 ..bub
      56
      57      if  lexdotrace ! punchexpand then  $ must output something.
      58          if  punchexpand then  mflshr(iwd);  end if;
      59          if  lexdotrace then  $ print out token trace.
      60              tintl('lexdo, typ', lextyp ha(iwd)) tintl('hash', iwd)
      61              tintl('length', lexlen ha(iwd))
      62              tintl('litcod', litcod ha(iwd)) textl(' symbol <')
      63              tokl(iwd) textl('>') endl
      64              end if;
      65          end if;
      66
      67      if  (tokwrt = no) cont while;  $ skip if not writing token file.
      68
      69      $   now check to see if there is a card that has not been sent
      70      $   to gen.  if so, send it.
      71      if  cardsent = no then    $ if card has not been sent.
      72          if  lastwd = 0 then  $ if last word not determined yet.
      73              do  lastwd = wpc to 2 by -1;  $ scan down card.
      74                  if  (iwds(lastwd) ^= blankword) quit do;
      75                  end do;
      76              end if;
      77
      78          tokrwd = 0;  tokrlen tokrwd = cpw*lastwd;  $ set length.
      79          tokrtyp tokrwd = tokrcard;  $ set token type.
      80          tokrlc tokrwd = icdno-icdlast;  icdlast = icdno;  $ set diff.
      81          tokout(tokrwd, iwds, 1);  $ write out on token file.
      82          cardsent = yes;  $ show card written.
      83          end if;
      84
      85 .+tallytokens     tally(tallyparse)  $ count tokens sent to parser
      86
      87      tokrtyp tokrwd = lextyp ha(iwd);
      88      tokrlen tokrwd = lexlen ha(iwd);  $ enter length in characters
      89      tokrlc tokrwd = litcod ha(iwd);
      90      if  lexlen ha(iwd) <= cpstr  then  $ if short record, write single
      91          tokrval tokrwd = tokrval names(nameptr ha(iwd));
      92          tokout1(tokrwd);
      93      else
      94          tokout(tokrwd, names, (nameptr ha(iwd)));
      95          end if;
      96      end while;
      97
      98      end subr lexdo;
      99 .+mp.
       1 .=member nextw
       2      subr  nextw;  $ starts expansion of macros.
       3      size  astkcardno(ps);  $ card no. when start to get macro args.
       4      size  imacsta(ps);  $ holds current place in -mstk-
       5      size  j(ps);            $ do loop index for argument collection
       6      size  mbeg(ps);  $ index in -mtab- of start of mac defn
       7      size  place(ps);  $ position on arg stack
       8      size  prevloc(ps);  $ start of previous argument
       9
      10      +*  astkput(v) =  $ add value to arguemt stack.
      11          astkpt = astkpt + 1;  $ increment pointer.
      12          if  astkpt > astklim then  $ this is an overflow.
      13              call ermsg(28, mname, astkcardno);  $ print error message.
      14              astkpt = initloc;  $ back up to last position.
      15              astkset(astkpt, 0);  $ reset to end of last argument.
      16              return;  $ done - get next token.
      17
      18          else    $   this entry will fit.
      19              astkset(astkpt, v);  $ add value to stack.
      20              end if;
      21          **
      22
      23      mname = iwd;  $ save name of macro.
      24      mbeg = macorg ha(mname);
      25      numargs = mtget(mbeg);
      26      if  numargs = 0  then  $ no arguments, prepare for expansion
      27 $    stack current location of argstack top, macstack top, and stack
      28 $       initial dictionary pointer for current macro
      29          if  mstkpt+3 <= mstklim  then $ add 3 entries
      30              mstk(mstkpt+1) = astkpt;
      31              mstk(mstkpt+2) = mstkpt; $ save current position
      32              mstk(mstkpt+3) = mbeg + 1;
      33              mstkpt = mstkpt+3;
      34              astkput(0);
      35              return;  $ get next symbol.
      36          else  $ mstk overflow, force overflow error exit
dso   11              call ermsg(21, 0, 0);  call lexexit;  $ fatal error.
      38              end if;
      39          end if;
      40
      41      dfabsrb(iwd);
      42      if  iwd ^= ihlp  then  $ error, called with no arguments
dso   12          call ermsg(1, mname, 0);  $ issue diagnostic
      44          keepwd = iwd;  return;
      45          end if;
      46
      47      astkput(0);
      48      prevloc = astkpt;
      49      initloc = prevloc;
      50      nparen = 0;
      51
      52      astkcardno = icdno;  $ record card no. at start of macro
      53      $ so if overflow occurs, we can list this card number.
      54      j = 1;  $ show processing first argument.
      55      while  yes;  $ loop until exited.
      56          dfabsrb(iwd);  $ get next token.
      57          nparen = nparen + (iwd=ihlp) - (iwd=ihrp);  $ new paren level.
      58          until  yes;  $ quit if this token ends argument.
      59              if  (nparen = 0 & iwd = ihcm) quit until;  $ comma.
      60              if  nparen < 0 then  $ this end the argument list.
      61                  if  j < numargs then  $ too few arguments.
dso   13                      call ermsg(2, mname, 0);  $ print error message.
      63                      astkpt = initloc;  astkset(astkpt, 0);  $ reset ex
      64                      return;  $ go get next token.
      65                      end if;
      66
      67                  $   else this is a normal end of argument list.
      68                  quit until;  $ first, it is an end of argument.
      69                  end if;
      70
      71              $   this is now an item in the arguments.  if this is not
      72              $   past the last argument, add to list.
      73              if  j <= numargs then  $ add to stack.
      74                  astkput(iwd);  $ add to stack.
      75                  end if;
      76
      77              cont while;  $ go around again.
      78              end until;
      79
      80          $   this is argument terminator.  unless past last argument,
      81          $   add entry to stack.
      82          if  j <= numargs then  $ ok.
      83              astkput(0);  astkset(prevloc, astkpt);  $ chain.
      84              prevloc = astkpt;  $ set new previous location.
      85              end if;
      86
      87          if  (nparen < 0) quit while;  $ done if last argument.
      88
      89          if  j = numargs then  $ too many arguments.
dso   14              call ermsg(3, mname, 0);  $ print error message.
      91              end if;
      92
      93          j = j + 1;  $ increment argument count.
      94          end while;
      95
      96      place = initloc;
      97      imacsta = mstkpt;
      98      do  j =  1 to  numargs;
      99          countup(mstkpt, mstklim,
     100                  'macro recursion or excessive nesting.');
     101          mstk(mstkpt) = place + 1;
     102          size  ipl(ps); ipl = place;
     103          place = astkget(place);  $ advance to next arg
     104          astkset(ipl, 0);
     105          end do;
     106
     107      if  mstkpt+3 <= mstklim  then  $ add 3 entries
     108          mstk(mstkpt+1) = initloc-1;
     109          mstk(mstkpt+2) = imacsta;
     110          mstk(mstkpt+3) = mbeg + 1;
     111          mstkpt = mstkpt+3;
     112          astkput(0);
     113          return;
     114      else  $ mstk overflow, force overflow exit
dso   15          call ermsg(21, 0, 0);  call lexexit;
     116          end if;
     117
     118      end subr nextw;
       1 .=member buildz
       2      subr buildz(wd, ndx, typ);  $ build zzy or zzz token.
       3      size  wd(ps);           $ ha index of token constructed.
       4      size  ndx(ps);          $ index of counter.
       5      size  typ(ps);          $ lexical type desired.
       6
       7      if  typ = dectok  then
       8          call fivdec(countzzy(ndx));  $ get trailer part
       9          slen hashtok = 5;
      10          tokch(1, fivdecara(1));  tokch(2, fivdecara(2));
      11          tokch(3, fivdecara(3));  tokch(4, fivdecara(4));
      12          tokch(5, fivdecara(5));
      13      else
      14          tokch(1, 1rz); tokch(2, 1rz);  tokch(3,1rz);
      15          tokch(4,(.ch. ndx, 'abcdefghijklmnopqrstuvwxyz_'));
      16          call fivdec(countzzz(ndx));  $ get numeric trailer
      17          tokch(5, fivdecara(1));  tokch(6, fivdecara(2));
      18          tokch(7, fivdecara(3));  tokch(8, fivdecara(4));
      19          tokch(9, fivdecara(5));
      20          slen hashtok = 9;
      21          end if;
      22
      23      hashtyp = typ;
      24      hashin(wd);
      25
      26      end subr buildz;
       1 .=member defabsrb
       2      subr defabsrb;  $ detects macro definitions, and digests them
       3 $        this routine collects macro definitions and enters macro text
       4 $    in macro dictionary.  tokens are obtained from mcexpand and
       5 $    are sent on to nextw.  the bulk of the code consists of
       6 $    tests for a variety of errors in macro definitions.
       7 $        the routine also punches out macro definitions if the user
       8 $    has requested this feature.
       9      size  ano(1);   $ set if duplicate argument.
      10      size  cno(ps);  $ holds bit position in zzz zzy var search
      11      size  j(ps);  $ do loop index
      12      size  increm(ps);  $ ha-index bias used in -mtab-
      13      size  startl(ps);  $ holds current -mtab- pointer when def begun
      14      size  ismacimm(1);  $ 'is this immediate macro.'
      15      size  firstsym(ps);  $ first token in macro text.
      16      $   casezzy and casezzz distinguish first from later instances
      17      $   of zzy and zzz symbols, respectively.  the new symbol is
      18      $   generated on expansion of first instance.
      19      size  casezzy(27), casezzz(27);
dsq  133      size  brkc(ws);  $ break string match function.
      20
      21 /top/
      22      j = iwd;   $ save + or *.
      23      mcexpnd(iwd);   $ get next token.
      24      if  iwd ^= ihst then  $ no macro definitions.
      25          keepwd = iwd;  iwd = j;  return;  end if;  $ return token.
      26
      27      if  j = ihst then  $ macro closer in open text.
dso   16          call ermsg(4, 0, 0);  iwd = 0;  $ give error message.
      29          return;  $ return ignoring tokens.
      30          end if;
      31
      32 /macname/
      33      mcexpnd(mname);  $ get macro name
      34      listapt = 0;  $ set argument list pointer.
      35 $    if lexical type is name, go off to continue processing.
      36 $    otherwise print diagnostic 'missing macro name'.
      37
      38      if  lextyp ha(mname) ^= nametok  then  $ error, not name
dso   17          call ermsg(8, mname, 0);  $ issue diagnostic
      40          go to flush;  $ flush macro definition.
      41          end if;
      42
      43      if  punchdefine  then  $ if punching macros, punch + * name
      44          mflshr(ihpl); mflshr(ihst);
      45          mflshr(mname);
      46          end if;
      47
      48      mcexpnd(iwd);
      49      if  iwd = iheq then  $ this starts the parameters.
      50          if  punchdefine then  mflshr(iheq);  end if;
      51      elseif  iwd = ihlp then  $  seen (, must have macro args
      52          if  punchdefine  then  mflshr(ihlp); end if;
      53          until  iwd ^= ihcm;  $ loop until end of argument list.
      54              mcexpnd(iwd);
      55              if  lextyp ha(iwd) = nametok then
      56                  ano = no;  $ if non-zero will be argument number
      57                  do  j =  1 to  listapt;
      58                      if  iwd=listarg(j) then  ano=yes; quit do; end if;
      59                      end do;
      60
      61                  if  ano ! iwd = mname  then  $ error - duplicate argu
      62                      call ermsg(17, iwd, mname);
      63                  else
      64                      countup(listapt, listarglim, 'listapt');  $ add ne
      65                      listarg(listapt) = iwd;  $ list of macro arguments
      66                      if  punchdefine  then  mflshr(iwd); end if;
      67                      end if;
      68                  end if;
      69
      70              mcexpnd(iwd);  $ get next token.
      71
      72              if  iwd = ihcm then   $ this is normal ender.
      73                  if  punchdefine then  mflshr(iwd);  end if;
      74              elseif  iwd ^= ihrp then  $ this is an error.
dso   18                  call ermsg(16, mname,0);  keepwd = iwd;  $ flag error.
      76                  end if;
      77              end until;
      78
      79          if  punchdefine  then  mflshr(iwd); end if;
      80
      81          mcexpnd(iwd);
      82          if  punchdefine  then  mflshr(iheq); end if;
      83
      84          if  iwd ^= iheq then
dso   19              call ermsg(15, mname, 0);
      86              keepwd = iwd;
      87              end if;
      88
      89      else  $ if not (or = after +*name, then have error
      90          call ermsg(9, iwd, mname);
      91          go to flush;  $ go flush macro definition.
      92          end if;
      93
      94 $    here begin to accumulate macro text.  get hash table entry, number
      95 $    of prior uses
      96 $    prior  macro flag.  if flagged as macro, go off to zero word
      97 $    preceeding macro text, allowing eventual garbage collection. if
      98 $    used before, go off to give warning message.  save location
      99 $    in macro-text dictionary for eventual garbage collection.
     100 $    note starting macro-text dictionary location
     101
     102      if  macorg ha(mname) = 0 then
     103          if  nuses ha(mname) > 1 then  $ warning - name with prior use
dso   20              call ermsg(10, mname, 0);  end if;
     105 .+mtgc.
     106      else
     107          if  macorg ha(mname) > 1  then  $ clear origin word
     108              mtset(macorg ha(mname)-1, 0);  end if;
     109 ..mtgc
     110          end if;
     111 .+mtgc   countup(mtptr, mtlim, 'macro gc word');
     112      $   reserve entry for macro argument count.
     113      countup(mtptr, mtlim, 'macro arg. count');
     114      startl = mtptr;
     115      casezzy = 0;  casezzz = 0;
     116
     117 $        at the 'gettext' label below we
     118 $    collect text up to a closing '**',
     119 $    reporting on '+*' which is illegal.
     120 $    the macro text is transferred into
     121 $    mtable.
     122
     123 /gettext/
     124 $   sequence for collection of macro-body text
     125      mcexpnd(iwd);
     126      if  iwd = ihst ! iwd = ihpl then  $ this could be opener or closer
     127          j = iwd;  $ save whichever it was.
     128          mcexpnd(iwd);  $ get next token.
     129          if  iwd ^= ihst then  $ if not star, then last was not special
     130              keepwd = iwd;  $ keep last token.
     131              if  punchdefine then  mflshr(j);  end if;
     132              iwd = j;  go to sendback;  $ go back to previous and proce
     133              end if;
     134
     135          $   this was now either a '+*' or a '**'.  in either case
     136          $   terminate the current macro but issue an error message
     137          $   in the case of '+*'.
     138          if  j = ihpl then  $ this is an error.
dso   21              call ermsg(22, 0, 0);  $ give error message.
     140              iwd = 0;  $ set flag to loop back.
     141              end if;
     142
     143          if  punchdefine then  mflshr(ihst);  mflshr(ihst);  end if;
     144
     145      else    $   not special token.
     146          if  punchdefine then  mflshr(iwd);  end if;
     147          go to putmaywd;  $ now put into table.
     148          end if;
     149
     150      if  mtptr <= startl then
     151 $    drop macro status of -mname-
     152          nuses ha(mname) = 0;  $ clear use field
     153 .+mtgc.
     154          if  macorg ha(mname) > 1  then  $ clear origin word
     155              mtset((macorg ha(mname))-1, 0);
     156              end if;
     157 ..mtgc
     158          macorg ha(mname) = 0;
     159          macimm ha(mname) = no;
     160          mtptr = mtptr - 1;  $ reclaim argument count word.
     161          go to trysend;  $ try to get next token.
     162          end if;
     163
     164      $   see if macro can be made immediate.
     165      ismacimm = no;
     166      until 1;
     167          if  (mtptr > (startl+1))  quit until;  $ if more than one symb
     168          if  (listapt)  quit until; $ if arguments.
     169          firstsym = mtget(mtptr);  $ get symbol.
     170          if  (firstsym <= 300)  quit until;  $ if arg or zzz symbol.
     171          firstsym = firstsym - 300;  $ convert to ha index.
     172          $ if symbol is itself macro, cannot make immediate so can
     173          $ still detect macro recursion.
     174          if  (macorg ha(firstsym))  quit until;
     175          $   if symbol is +, cannot make immediate because of
     176          $   possibility of occurring in a macro definition.
     177          if  (firstsym = ihpl) quit until;
     178
     179          ismacimm = yes;  $ is immediate macro.
     180          end until;
     181
dso   22      if  (macorg ha(mname)) call ermsg(11, mname,0); $ redefining macro
     183
     184      macimm ha(mname) = ismacimm;
     185      if  ismacimm  then  $ if immediate.
     186          macorg ha(mname) = firstsym;
     187          mtptr = startl  - 1;
     188      else
     189          countup(mtptr, mtlim, 'mt');
     190          mtset(mtptr, 0);  $ mark end of macro text
     191 .+mtgc   mtset(startl, mname); $ record macro name index
     192          mtset(startl, listapt);  $ enter argument count.
     193          macorg ha(mname) = startl;
     194          end if;
     195
     196 /trysend/
     197      if  (iwd = 0) go to macname;  $ loop in error case.
     198      mcexpnd(iwd);  $ get the next token.
     199      if  (iwd = ihpl) go to top;  $ start again if +.
     200      return;  $ else return token.
     201
     202 /putmaywd/
     203      if  listapt  then  $ if arguments, see if argument.
     204          if  lextyp ha(iwd) = nametok  then  $ check only names.
     205              do  j = 1 to listapt;
     206                  if  iwd = listarg(j)  then
     207                      countup(mtptr, mtlim, 'mt');
     208                      mtset(mtptr, j);
     209                      go to gettext;  $ continue definition search.
     210                      end if iwd;
     211                  end do j;
     212              end if;
     213          end if listapt;
     214
     215   until 1;
     216      if  (lexlen ha(iwd) ^= 4) quit until; $ not zzz type
     217      if  (lextyp ha(iwd) ^= nametok) quit until;
     218      if  (.f. ws+1-2*cs, 2*cs, names(nameptr ha(iwd)) ^= 2rzz) quit;
     219      j = .f. ws+1-3*cs, cs, names(nameptr ha(iwd));  $ get third char
     220      if  (j=1rz) ! (j=1ry)  then
     221          cno = lettercode((.f. ws+1-4*cs, cs,names(nameptr ha(iwd))));
     222          if  (cno=0) quit until ;$ must be alphabetic, els skip
     223          increm = 100;
     224          if  j = 1ry  then  $ if zzy symbol.
     225              increm = increm + 50;
     226              if  .f. cno, 1, casezzy = 0  then  $ if first instance.
     227                  .f. cno, 1, casezzy = 1;
     228                  increm = increm + 100;
     229                  end if;
     230          else
     231              if  .f. cno, 1, casezzz = 0  then  $ if first instance.
     232                  .f. cno, 1, casezzz = 1;
     233                  increm = increm + 100;
     234                  end if;
     235              end if;
     236          countup(mtptr, mtlim, 'mt');
     237          mtset(mtptr, increm+cno); $ add biased symbol code to text
     238          go to gettext;
     239          end if;
     240   end until;
     241
     242 $  +* macro = zzza,zzza,zzyc,zzyc,zzyc**
     243 $    is put in mtable in the form
     244 $    201,101,253,153,153
     245
     246      if  iwd = mname then  $ error - macro occurs in self
dso   23          call ermsg(13, iwd, 0);  go to gettext; end if;
     248
     249 /sendback/
     250      countup(mtptr, mtlim, 'mt');
     251      mtset(mtptr, iwd+300);  $ enter standard token in text
     252      go to gettext;
     253
     254 /flush/  $ flush macro definition because of error.
     255      until  j = ihst & iwd = ihst;   $ until two stars.
     256          j = iwd;  mcexpnd(iwd);
     257          if  j = ihpl & iwd = ihst then  $ +* found.
dso   24              $ give error and continue.
dso   25              call ermsg(22, 0, 0);  go to macname;
     259              end if;
     260
     261          end until;
     262
     263      iwd = 0;  $ show no token gotten.
     264
     265      end subr defabsrb;
       1 .=member mcexpand
       2      subr mcexpand;  $  expands macros
       3 $    this routine expands macros, obtaining next token from trulex
       4 $    if no macros to expand.
       5
       6      size  aptr(ps);  $ index to part of macro arg list
       7      size  indx(ps);   $ index for zzzy, zzzz.
       8
       9 $    the encoding used in this section is as follows -
      10 $    pointers to the macro-text dictionary are integers not greater
      11 $    than the dimension 'mtlim' of the  dictionary. pointers
      12 $    to the argument stack are offset by a positive increment
      13 $    equal to mtlim
      14
      15 /macnext/
      16      aptr = mstk(mstkpt);
      17      if  aptr > mtlim  then  $ if expanding macro argument
      18          iwd = astkget(aptr - mtlim); $ next word in argument
      19          if  iwd = 0 then  $ have reached end of argument
      20              mstkpt = mstkpt - 1;  $ move down to next arg
      21              mstk(mstkpt) = mstk(mstkpt) + 1; $ move to next mac item
      22              if  (mstkpt > 1) go to macnext;  $ if more to do.
      23
      24          else  $ return word of macro text
      25              mstk(mstkpt) = aptr+1;
      26              end if;
      27
      28      else
      29          iwd = mtget(aptr);  $ get item from macro text
      30          if  iwd = 0 then  $ end of macro,restore state
      31              astkpt = mstk(mstkpt-2);  $ restore argstak pointer
      32              mstkpt = mstk(mstkpt-1);  $ restore mstak pointer
      33              if  (mstkpt) go to macnext;  $ continue if more ma
      34
      35          else
      36              if  iwd < 100 then  $ begin argument copy
      37                  countup(mstkpt, mstklim, 'mstk');
      38                  mstk(mstkpt) = mstk(mstk(mstkpt-2) + iwd) + mtlim;
      39                  go to macnext;
      40              else
      41                  if  iwd < 300 then  $ zzzy or zzzz case.
      42                      indx = mod(iwd-100, 50);  $ get case index.
      43                      go to zy((iwd-100)/50) in 0 to 3;
      44                   /zy(2)/ countzzz(indx) = countzzz(indx)+1;
      45                   /zy(0)/ call buildz(iwd, indx, nametok);
      46                      go to zydone;
      47                   /zy(3)/ countzzy(indx) = countzzy(indx)+1;
      48                   /zy(1)/ call buildz(iwd, indx, dectok);
      49                  else
      50                      iwd = iwd-300;
      51                      end if;
      52
      53                  /zydone/ mstk(mstkpt) = mstk(mstkpt) + 1;
      54                  end if;
      55              end if;
      56          end if;
      57
      58      end subr mcexpand;
      59 ..mp
       1 .=member trulex
       2      subr trulex;   $  gets tokens, eliminates comments
       3
       4 $    the routine -trulex- collects input characters together
       5 $    into tokens.
       6
       7      size  c(cs);          $ character scanned
       8      size  len(ps);                   $ string length.
       9      size  delimchar(cs);  $ delimiter for 0-type string constants
      10      size  i(ps);    $ while and do loop index
      11      size  bitmax(ps);    $ code for maximum acceptable char in bit con
      12      $   need nultyp since lexca may also call hash and so set hashtyp.
      13      size  nultyp(ps);       $ new lexical type.
      14      size  blankinsidenumeric(1);  $ on if numeric contained blank.
dsq  134      size  anyc(ws);    $ any string match function.
dsv   49 .+mc size  ctpc(cs);   $ function to convert character to primary case.
dsq  136      size  brkc(ws);  $ break string match function.
      15
      16
      17 /scanon/
      18      tokptr = 0;  $ reset token pointer
      19
      20      giveq(c);  $ get a character.
      21
      22 /newchar/  $ here to process a gotten character.
      23 .+bskp_env.  $ if assembler blank skip.
dsqa   1      while  c=1r ;
      25          call 7nbskp$li(iwds, nowdp, nc10, nowc, nowd, c, tallyeol);
dsqc   1          $   if rest of line blank, then read next line
dsqc   2          $   and process here following lines which have
dsqc   3          $   initial $ and hence are comments.
dsqc   4          if  nowc>mccd & c=1r  then  $ if rest blank.
dsqa   3              while 1;
dsqa   4                  call givecr(c);  $ get next line.
dsv   50 .+mc             c = ctpc(c);  $ in case first char is other-case.
dsqa   6                  if  (c^=1r$)  quit while;
dsqa   7 .+tallycomments  tally(tallyeol);
dsqa   8                  end while;
dsqa   9              end if;
dsqa  10          end while;
dsq  137      $   bskp skips only blanks so need check again in case
dsq  138      $   character is now non-blank separator.
dsq  139 ..bskp_env
      28      $   we know that blanks cannot be in -keep- so we can use a
      29      $   quicker scan.
dsq  140      while  isblank(c);  giveqnk(c);  end while;
      32
dsq  141  if anyc(c, ss_immed)  then  $ if immediate token.
      34 .+tallytokens  tally(tallyimtok) $ count immediate tokens
      35 .+ht.
      36      if  hashtrace  then  textl(' imtok=') charl(c) charl(1r ) end if;
      37 ..ht
dsq  142          iwd = imtoktab(1+brkc(imtoks, 1, c));
dsq  143          return;
      39
      40 elseif  alphabetic(c)  then  $ if name.
      41          nultyp = nametok;
      42          while  alphameric(c);  charin(c);  giveq(c);  end while;
      43          go to endc;
      44
      45 elseif  numeric(c)  then
      46
      47          nultyp = dectok;
      48          blankinsidenumeric = no;
      49          while  1;
      50              charin(c);  giveq(c);
      52              if  (numeric(c)) cont while;  $ continue if numeric.
dsq  144              if  isblank(c)  then  $ look for run of blanks in integer
      54                  blankinsidenumeric = yes;
dsq  145                  while  isblank(c);  giveqnk(c);  end while;
      56                  if  (numeric(c)) cont while;
      57                  go to endc;
      58              elseif  c = 1rb  then
      59                  if  (tokptr>1)  go to endc;
      60                  i = digofchar(tok(1));
      61                  if  (i<1 ! i>4)  go to endc;
      62                  givec(c);
      63                  if  c=1r'  then  charin(1rb);
      64                  else  keepc(1rb);  go to endc;  end if;
      65                  nultyp = bittok;
dsq  146                  bitmax = 0;
      67                  .f. i+1, 1, bitmax = 1;
      68                  do  i = 1 to maxtoklen-3;
      69                      tokptr = tokptr+1;  tok(tokptr) = c;  giveqnk(c);
      70                      if  c = 1r'  then  $ if end of constant.
      71                          tokptr=tokptr+1;  tok(tokptr)=c;  go to endc2;
dsq  147                      $ gen requires blanks within constants
dsq  148                      elseif  isblank(c)  then c = 1r ;
dsq  149                      $   here to check for valid code.
dsq  150                      elseif  brkc('0123456789abcdef', 1, c) < 0
dsq  151                          ! brkc('0123456789abcdef', 1, c)>=bitmax  then
dso   26                          call ermsg(32,c,0);
      75                          c = 1r0;
      76                          end if;
      77                      end do;
dso   27                  call ermsg(33, 0, 0);
      79              elseif  c = 1r.  then  go to periodafterint;
      80              elseif  c = 1re  then  $ insert e, go get exponent.
      81                  charin(1re);  givec(c);  go to getexpval;
      82              elseif  alphabetic(c)  then  quit while;
      83              else  go to endc;
      84                  end if;
      85              end while;
      86
      87          if  alphabetic(c)  then
      88          if  (tokptr>5)  go to endc;
      89          if  (blankinsidenumeric)  go to endc;
      90          if  c = 1rn  then  nultyp = nametok;
      91          elseif c = 1rq  then nultyp = stringtok;
      92          elseif c = 1rr  then nultyp = rztok;
      93          elseif c = 1rs  then nultyp = sstok;
      94          else  go to endc;  end if;
      95
      96          len = 0;
      97          do  i = 1 to tokptr; len = len*10 + digofchar(tok(i)); end do;
      98          tokptr = 0;  $ reset token pointer
      99          $ see if next char after integer is string type char
     100          $ in which case then collect and format string contents
     101          if  len = 0  then  $ contents are delimited
     102              givecstr(delimchar);
     103              givecstr(c);  $ first char in contents
dsv   51 .+mc         if (nultyp=sstok ! nultyp=nametok) c = ctpc(c);
dsq  153              while  c ^= delimchar;
dsq  154                  charin(c);
dsq  155                  givecstr(c);
dsv   52 .+mc             if (nultyp=sstok ! nultyp=nametok) c = ctpc(c);
dsq  157                  end while;
     105              len = tokptr;  $ save length of delimited string
     106          else     $ length known, accumulate contents
dsq  158              do  i = 1 to len;
dsq  159                  givecstr(c);
dsv   53 .+mc             if (nultyp=sstok ! nultyp=nametok) c = ctpc(c);
dsq  161                  charin(c);
dsq  162                  end do;
     108              end if;
     109          go to endc2;    $ current character absorbed
     110          else  go to endc;  end if;
     111
     112 elseif  c = 1r$  then
     113
     114          call givecr(c);  $ read next card
dsw   16 .+mc     c = ctpc(c);  $ convert to primary case.
     115 .+tallycomments   tally(tallyeol)  $ count eol comments
     116          go to newchar;
     117
     118 elseif  c = 1r/  then
     119
     120 $    we have seen  /. if * follows, then collect comment; otherwise
     121 $    token is /.  we monitor inside of comment for unexpected  / * .
     122          givec(c);
     123 $   reach here after seeing slash asterisk, so check
     124 $   for corresponding asterisk slash  closure
     125          if  c ^= 1r*  then  $ not pl1 comment, end token
     126 .+ht.  $ if hash trace on, hash in normally to get trace.
     127              if  hashtrace  then
     128                  charin(1r/);  nultyp = spectok;  go to endc;
     129                  end if;
     130 ..ht
     131              iwd = ihsl;  $ token is slash.
     132              keepc(c);  $ save character after slash.
     133              return;
     134              end if;
     135 $    now absorb pl1 style comment
     136 .+tallycomments   tally(tallypl1) $ count pl/1 comments
     137      while  1;  $ collect comment body.
     138          givec(c);  $ loop while asterisk seen
     139          if  c=1r/  then  $ if / * inside comment, treat as error.
     140              givec(c);
dso   28              $ error if see / * inside comment.
dso   29              if  (c=1r*)  call ermsg(27, 0, 0);
     142              end if;
     143          if  (c ^= 1r*) cont while; $ continue if not -*-
     144          givec(c);  $ now see if / after *
     145          while c=1r*; givec(c); end while; $ look for run of *'s.
     146          if  (c=1r/)  quit while;
     147          end while;
     148      go to scanon;
     149
     150 elseif  c = 1r'  then
     151
     152          nultyp = stringtok;
     153 $        here we collect quoted string, using givecstr to get character
     154 $        since inside string
     155          while tokptr <= maxtoklen-2;  $ at most lnqtmax chars in strin
     156              givecstr(c);
     157              if  (c=1r')  then
     158                  givecstr(c);  $ get char after quote
dsq  163                  if  c ^= 1r'  then  $ if end of string.
dsv   54 .+mc                 c = ctpc(c); $ fold following character.
dsq  165                      go to endc;
dsq  166                      end if;
     160                  end if;
     161          tokptr = tokptr+1;  tok(tokptr) = c;  $ add to token.
     162              end while;
dso   30          call ermsg(18,maxtoklen, 0);  go to endc;
     164
     165 elseif  c = 1r.  then
     166
     167          charin(c);  $ dot begins token.
     168          givec(c);
     169          if  numeric(c)  then  go to real3;  $ if  real constant.
     170          elseif  alphabetic(c) = no  then  $ if not start of op.
     171              nultyp = spectok;  go to endc;  $ is special token.
     172          end if;
     173
     174          nultyp = optok;
     175          charin(c);  givec(c);
     176          while alphabetic(c);  charin(c); givec(c); end while;
     177          if  c=1r.  then  charin(c);  else  go to endc2;  end if;
     178 $       end of period-delimited token. check for special operator
     179 $        type tokens which have special meaning to scanner
     180 $        tokens and actions are
     181
     182 $    .chtr.        trace each character received from -givec-
     183 $    .nochtr.      end character trace
     184 $    .hatr.        enable trace of hash routine
     185 $    .nohatr.      end hash trace
     186 $    .lextr.       trace tokens sent to parser ,ie from nextw)
     187 $    .nolextr.     end parser token ttace
     188 $    .compdate.    return string with compilation date.
     189
     190
     191      $   .mactr.  trace macro routines
     192 $   .nomactr.  disable trace of macro routines
     193
     194 $    any special tokens detected are absorbed here
     195
     196      if  (tokptr <= 5) go to endc2;    $ special at least six character
     197      sdspack(tok, tokptr);  $ pack into hashtok for hash
     198      $  hash in token so can see if special
     199      hashtyp = optok;
     200      hashin(iwd);
     201      do  i =  1 to  numbugtoks;  $ search for special bug token
     202          if  (bugtoks(i) ^= iwd) cont do;
     203          go to bt(i) in 1 to numbugtoks;
     204 /bt(1)/    /bt(2)/
     205 .+ct     chartrace = (i=1);
     206          go to scanon;
     207
     208 /bt(3)/    /bt(4)/
     209 .+ht     hashtrace = (i=3);
     210          go to scanon;
     211
     212 /bt(5)/    /bt(6)/
     213          lexdotrace = (i=5);
     214          go to scanon;
     215
     216 /bt(7)/    /bt(8)/
     217 .+mt     mactrace = (i=7);
     218          go to scanon;
     219
     220 /bt(9)/  iwd = ihcompdate;  return;  $ pass on date.
     221          end do;
     222
     223      $   since not special, pass on to parser.
     224      return;  $ no need to hash again
     225
     226 else  $ if special token.
     227          charin(c);
     228          nultyp = spectok;
     229          go to endc2;
     230          end if;
     231
     232 /periodafterint/
     233 $    we have seen '123.' - may have real, or integer followed by dot-op
     234      givec(c);
     235      if  numeric(c)  then  $ if next char numeric, must have real
     236          charin(1r.);  go to real3;
     237
     238      elseif  alphabetic(c) & (c^=1re)  then
     239 $        if  letter other than e follows ., have dot-op after int.
     240          keepc(c);  keepc(1r.);
     241          go to endc2;
     242
     243      elseif  c=1re  then  $ if have 123.e, may be real or operator
     244          givec(c);
     245          if  numeric(c) ! c=1r+ ! c=1r-  then  $ definitely real
     246              charin(1r.);  charin(1re);  go to getexpval;
     247          else  $  not exponent, so have integer then dot-op
     248              keepc(c);  keepc(1re);  c = 1r.;  go to endc;
     249              end if;
     250      else  $ dot is not part of dot-op, so have simple real
     251          charin(1r.);  nultyp = realtok;  go to endc;
     252          end if;
     253
     254 /real3/
     255      $  seen real, collect remaining numeric part, then exponent if pre
     256      nultyp = realtok;
     257      if  numeric(c)  then  $ collect numbers, watch for internal blanks
     258
     259          while numeric(c);
     260              charin(c);  givec(c);
dsq  167              if  isblank(c)  then  $ if blank, watch for run of blanks
dsq  168                  while  isblank(c);  givec(c);  end while;
     263                  if  (numeric(c)=no)  go to endc;  $ at end of run
     264                  $ must see numeric to remain inside constant
     265                  end if;
     266              end while;
     267
     268          end if;
     269      if  c=1re  $ if exponent present, digest it.
     270          then charin(c); givec(c);
     271          else go to endc;  end if;
     272
     273 /getexpval/
     274      $ collect exponent value
     275      nultyp = realtok;
     276      if  c=1r+ ! c=1r-  then  charin(c);  givec(c);  end if;  $ absorb
     277          $ sign field, if present.
     278
     279      if  numeric(c)  then  $ absorb value, watching for internal blanks
     280          while numeric(c);
     281              charin(c); givec(c);
dsq  169              while  isblank(c);  givec(c);  end while;
     283              end while;
     284      else  $ missing exponent value, take 0
dso   31          call ermsg(26, 0, 0);
     286          charin(1r0);
     287          end if;
     288      go to endc;
     289
     290 /endc/
     291      keepc(c);
     292 /endc2/
     293 $    pack token into -hashtok-, set length, hash in.
     294      sdspack(tok, tokptr);  $ pack token into hashtok.
     295      hashtyp = nultyp;
     296      hashin(iwd);  $ hash and set -iwd- to hash-index obtained
     297
     298      end subr trulex;
       1 .=member givesp
       2      subr givesp(ic);  $ get char. inside string.
       3      size  ic(ps);
       4
       5      if  keepindex  then  $ if prior token kept.
       6          getfromkeep(ic);
       7      elseif  nowc > mccd  then  $ elseif new card needed.
       8          call givecr(ic);    $ read next card.
       9      else
      10          if  nc10 = 1 then  $ if need next word
      11              nowdp = nowdp + 1;
      12              nowd = iwds(nowdp); $ fetch next word.
      13              nc10 = ws + 1;
      14              end if;
      15          nc10 = nc10 - cs;   $ advance to next character position.
      16          ic = .f. nc10, cs, nowd;  $ extract character.
      17          nowc = nowc + 1;
      18          end if;
      19 .+ct.
      20      if  chartrace  then  $ if tracing characters.
      21          textl(' ct=<') charl(ic) textl('> ')
      22          end if;
      23 ..ct
      24      return;
      25      end subr givesp;
       1 .=member givecp
       2      subr givecp(c);  $ get character
       3      size  c(cs);
dsv   55 .+mc size  ctpc(cs);   $ function to convert character to primary case.
       4      givec_text(c);
       5      return;
       6      end subr givecp;
       1 .=member givecr
       2      subr givecr(ic);  $ process card (list, output, ca, .. etc)
       3      size  ic(cs);  $ returned character
       4      size  work(ps);  $ work to do; see -normwork- in -start-
       5 .+ca size  col(ps);  $ no. cols to clear (ca)
       6      size  i(ps), j(ps);  $ do loop indexes
dsq  171      size  anyc(ws);  $ any string match function.
dsv   56 .+mc size  ctpc(cs);  $ function to convert to primary case character.
       7
       8 /reread/
       9      work = normwork;  $ set to normal options
      10      if  errecho then  $ just want to list
      11          work = list_work; $ just set list flag
      12          go to l(list_work);
      13          end if;
      14
      15      call getinc(iwds, 1, wpc, iorc);  $ read next card
      16      if  iorc then  $ end-of-file
      17          exitcode = 0; call lexexit; $ exit at end of file
      18          end if;
      19
      20      icdno = icdno+1;  $ increment cards read counter
      21
      22      $   now check if this could overflow the -tokrlc- field.
      23      if  icdno-icdlast > 200 then  $ could overflow.
      24          if  tokwrt then   $ if writing token file.
      25              $   must write out null card.
      26              tokrwd = 0;  tokrtyp tokrwd = tokrcard;  $ set type.
      27              tokrlc tokrwd = icdno-icdlast;  $ insert value.
      28              tokout1(tokrwd);  $ write to token file.
      29              end if;
      30
      31          icdlast = icdno;  $ set new line number.
      32          end if;
      33
      34      cardlisted = no;  $ show card not listed yet
      35      lastwd = 0;  $ set unknown last word
      36
      37      $   now check for directive or conditional card
      38      until yes;   $ start 'maybe' loop
      39          if  (.f. ws+1-2*cs, cs, iwds(1) ^= 1r.) quit until;
      40          if  (alphabetic((.f. ws+1-4*cs,cs, iwds(1))) = no) quit until;
      41 $ *********note********* above assumes at least 4 chars/word
      42          if  (.f. ws+1-1*cs, cs, iwds(1) ^= 1r ) quit until;
      43          $   may now have card of interest - check column 3
      44          col3char = .f. ws+1-3*cs, cs, iwds(1);
      45          if  col3char = 1r= & cardskip = no then $ may be directive
      46              call lexdir(work);  $ process if so
      47 .+ca.
      48          elseif  iscachar(col3char) then  $ may be ca
      49              call lexca(work, col);  $ process if so
      50 ..ca
      51              end if;
      52          end until;
      53
      54      $   the variable -work- has been set to select the work that must
      55      $   be done on the current card.  the -go to- statement branches
      56      $   to labels which select the order in which the work is
      57      $   to be done.
      58      while  work;  $ loop until no work to
      59          work = work ! 1b'10000';     $ turn on extra bit.
      60          go to l(work) in 17 to list_work!elim_work!out_work!proc_work;
      61
      62 /l(list_work!out_work!elim_work!proc_work)/
      63 /l(list_work!out_work!elim_work          )/
      64 /l(list_work!out_work          !proc_work)/
      65 /l(list_work!out_work                    )/
      66 /l(list_work         !elim_work!proc_work)/
      67 /l(list_work         !elim_work          )/
      68 /l(list_work                   !proc_work)/
      69 /l(list_work                             )/
      70          work = work & ^list_work;  $ clear list flag
      71          if  (cardlisted) cont while;  $ dont list twice
      72          cardlisted = yes; $ show will list card
      73          if  lastwd = 0 then  $ determine last word to list
      74              do  lastwd = wpc to 2 by -1; $ get blanks off end
      75                  if  (iwds(lastwd) ^= blankword) quit do;
      76                  end do;
      77              end if;
dsq  173      intl(icdno)  $ print line number.
dsq  174      $   print tab if available to retain correct tabular alignment.
dsq  175      if  cc_tab ^= 1r   then  $ list tab if available.
dsq  176          charl(cc_tab)
dsq  177      else  $ else list two blanks.
dsq  178          skipl(2)
dsq  179          end if;
      79          call wordsr(iwds, 1, lastwd);  $ list line.
      80          endl  $ end of line
      81          cont while;
      82
      83 /l(elim_work!out_work!proc_work)/
      84 /l(elim_work!out_work          )/
      85 .+ca     if  (.f. list_qualifiers, 1, listnow) go to l(out_work);
      86
      87 /l(elim_work!proc_work)/
      88 /l(elim_work          )/
      89 .+ca.
      90          work = work & ^elim_work;  $ turn off flag
      91          i = col/cpw;  $ set no. words to clear
      92          do  j = 1 to i;  $ clear each word
      93              iwds(j) = blankword;
      94              end do;
      95          i = col - i*cpw; $ set no. remaining cols to clear
      96          if  (i) .f. ws+1-i*cs, i*cs, iwds(j) = blankword; $ clear
      97          cont while;
      98 ..ca
      99
     100 /l(out_work!proc_work)/
     101 /l(out_work          )/
     102          work = work & ^out_work;  $ reset flag.
     103          if  tokwrt then  $ write to token file
     104          $   if gen will not list cards, then it will only
     105          $   need a card if there is an error detected.  however,
     106          $   there cannot be an error on a card without tokens.
     107          $   therefore, if gen will not list cards, we should not
     108          $   pass the card unless there are tokens on it.  so set
     109          $   a flag and have -lexdo- send the card.
     110          if  listingen = no then  $ gen will not list.
     111              cardsent = no;  $ set flag to show not sent.
     112              cont while;  $ done with this bit of work.
     113              end if;
     114
     115              if  lastwd = 0 then  $ must check for last word
     116                  do  lastwd = wpc to 2 by -1;  $ find last non-blank
     117                      if  (iwds(lastwd) ^= blankword) quit do;;
     118                      end do;
     119                  end if;
     120              tokrwd = 0; tokrlen tokrwd = cpw*lastwd; $ set length
     121              tokrtyp tokrwd = tokrcard;  $ code for card
     122              tokrlc tokrwd = icdno-icdlast;  $ set number of cards.
     123              icdlast = icdno;  $ reset last card number.
     124              tokout(tokrwd, iwds, 1);  $ output card image
     125              cardsent = yes;  $ show card sent to gen.
     126              end if;
     127          cont while;
     128
     129 /l(proc_work)/
     130          $   now, set to read first char on card
     131          nowdp = 1;  $ point to first word of card
     132          nc10 = ws-cs+1;  $ point to next char position
     133          nowd = iwds(1);  $ first word of card
     134          ic = .f. ws-cs+1, cs, nowd;  $ get first char
     135          nowc = 2;  $ next char will be col 2
     136          return;
     137
     138          end while;
     139
     140      $   done with all work.  we now either read another card or,
     141      $   if -errecho- is set, return.
     142      if  (errecho = no) go to reread;
     143      errecho = no;  $ reset flag
     144
     145      end subr givecr;
       1 .=member lexca
       2      subr lexca(work, col);  $ process conditional card
       3      $   this routine processes the conditional qualifiers that may
       4      $   appear on cards.  it is responsible for setting -normwork-
       5      $   and -cardskip- when a skip is to be done or ends.
       6      size  work(ps);  $ work to be done on card
       7      size  col(ps);   $ output - no. of cols to clear
       8      size  i(ps);     $ do loop index
       9      size  c(cs);     $ character from card
dsq  180      size  anyc(ws);   $ any string match function.
dsv   57 .+mc size  ctpc(cs);   $ function to map character to primary case.
      10
      11      +*  getc(ic) =  $ macro to get next character from card
      12          if  nowc > mccd then  $ at end of card
      13              ic = 1r$;  $ pass non-alpha and non-blank
      14          else
      15              if  nc10 = 1 then  $ new word needed
      16                  nowdp = nowdp+1; nowd = iwds(nowdp);
      17                  nc10 = ws+1;  $ reset to start of word
      18                  end if;
      19              nc10 = nc10-cs;  $ advance to next character
dsv   58 .+mc         ic = ctpc((.f. nc10, cs, nowd));
dsv   59 .-mc         ic = .f. nc10, cs, nowd;
dsq  184              nowc = nowc+1;
      21              end if;
      22          **
      23
      24      nowc = 4; $ next char is fourth
      25      nowdp = 1;  $ set to word 1 **** assumes cpw >= 4****
      26      nowd = iwds(1);  $ get proper word
      27      nc10 = ws+1+cs-4*cs;   $ set to place to get next char.
      28
      29      if  cardskip then  $ must find matching name.
      30          do  i = 1 to canamel; $ compare each character
      31              getc(c); if (c ^= caname(i)) return; $ ignore card if not
      32              end do;
      33          $   name matches, ensure next character is not part of name.
      34          getc(c); if  (alphameric(c)) return;  $ not matching if so
      35      else  $ get ca name
dsy   12           getc(c);
dsy   13           if alphabetic(c)=no then  $ if first not alphabetic
dsy   14               call ermsg(6,0,0); $ report error.
dsy   15               return;
dsy   16               end if;
dsy   17           caname(1) = c;
dsy   18          do  canamel = 2 to mccd;  $ collect name - loop will be -quit-
      37              getc(c);  $ get a character
      38              if  (alphameric(c) = no) quit do;  $ stop at non-alpha
      39              caname(canamel) = c;  $ insert character
      40              end do;
      41          canamel = canamel-1; $ reset because last character not in str
      42          end if;
      43
      44      $   we now have conditional name to process.  hash in and
      45      $   determine new status.
      46      sdspack(caname, canamel);  $ pack into -hashtok-
      47      hashtyp = nametok; hashin(hashca);  $ hash in
      48
      49      if  col3char ^= 1r. & hashca = hashcaset then  $ this is 'set'
      50          while  c ^= 1r$;  $ loop until end of input
dsy   19              until  alphabetic(c) ! c = 1r$;  $ skip blanks
      52                  getc(c);  $ get next character
      53                  end until;
      54              canamel = 0;  $ reset name length
      55              while  alphameric(c);  $ process name
      56                  canamel = canamel+1; caname(canamel) = c; $ set char.
      57                  getc(c);  $ get next character
      58                  end while;
      59              if  canamel then  $ name present
      60                  sdspack(caname, canamel);  $ pack ino -hashtok-
      61                  hashtyp = nametok; hashin(hashca);
      62                  cab ha(hashca) = (col3char = 1r+); $ set value
      63                  end if;
      64              end while;
      65          work = work & ^proc_work;  $ dont scan for tokens
      66          if  (.f. list_qualifiers, 1, listnow = no) $ dont send to -gen
      67              work = work & ^out_work;  $ dont write to token file
      68          return;  $ done in this case
      69          end if;
      70
      71      $   we now have a 'normal' conditional card.  see if we should
      72      $   skip this card and whether -cardskip- should be set.
      73      if  col3char = 1r. then  $ this always ends skip
      74          cardskip = no; $ set no skip
      75      else  $ test -cab- agreement
      76          cardskip = ((col3char = 1r+) ^= cab ha(hashca));
      77          work = work ! (out_work!proc_work);  $ set default values
      78          if  cardskip then  $ this card will be skiped
      79              work = work & ^proc_work;  $ -lex- wont process
      80              if  (.f. list_skip, 1, listnow = no) $ dont give to -gen-
      81                  work = work & ^out_work;  $ dont write to token file
      82              cardskip = (c = 1r.);  $ only skip if next char is '.'.
      83              end if;
      84          end if;
      85
      86      $   finally, set final status according to -cardskip-.
      87      if  (work & ^list_work) work = work ! elim_work;  $ elim if needed
      88      col = nowc-1;  $ set elimination boundary
      89      normwork = normwork ! (out_work!proc_work); $ set to process.
      90      if  cardskip then  $ dont process until further notice.
      91          normwork = normwork & ^proc_work;  $ dont process
      92          if  (.f. list_skip, 1, listnow = no)  $ dont list in -gen-
      93              normwork = normwork & ^out_work;  $ dont write to token
      94              end if;
      95
      96
      97      macdrop(getc)
      98      end subr lexca;
       1 .=member lexdir
       2      subr lexdir(work);  $ parse input directive
       3      $   process  .=eject  .=list  .=punch  .=title
       4
       5      $   line is sds form of current line.  lorg is macro giving
       6      $   string origin.
       7      +*  lorg = (1 + .sds.(cpw*wpc)) **
       8      +*  linech(i) = .f. lorg -(i)*cs, cs, line**  $ ith character of l
       9      $   ara holds words to be written on token file.
      10      $   ara will contain several list entries, eject entry or
      11      $   title entry.
      12      size  ara(ws);  dims ara(wpc+2);
      13      size  araptr(ps);       $ top of ara list.
      14      size  c(cs);            $ character.
      15      size  i(ps), j(ps), l(ps);    $ counters.
      16      size  work(ps);  $ work value for card
      17      size  key(.sds.10);
      18      size  keycode(ps);      $ position in directive code list.
      19      size  line(lorg-1);   $ input line as string.
      20      size  lpos(ps);        $ start of parameter list.
      21      size  parmvalue(1);     $ set if parm present.
      22      size  pgiven(ps);       $ bit i set if ith code present.
      23      size  pl(ps);
      24      size  prm(.sds. 6);     $ parameter from list.
      25      size  pvalue(ps);       $ bit i set if ith code set.
      26      $   parmstr gives list of directive codes.
      27      size  parmstr(.sds. (5 +7*numlistparms));
      28      size  prmcopy(.sds. 6); $ copy of parm if 'no' given.
      29      size  resuming(1);      $ on when resuming previous list status.
      30      size  tokrwd(ws);       $ word for token file.
      31      size  lexlist(1); $ on to list card in -lex-
      32      size  genlist(1); $ on to list card in -gen-
      33      size  listdir(1); $ value of 'dir' parm
dsq  185      size  anyc(ws);   $ any string match function.
dsv   60 .+mc size  ctpc(cs);   $ function to convert character to primary case.
dsq  187      size  brkc(ws);  $ break string match function.
      34
      35      l = 0;
      36      sorg line = lorg;
      37      do  i = 1 to wpc;
      38          .f. lorg - i*ws, ws, line = iwds(i);
      39          end do i;
      40      sorg line = lorg;
      41      slen line = mccd + 1;
      42      linech(mccd+1) = 1r ;
      43      lpos = 3;
dsq  188      until isblank(linech(lpos));
      45          lpos = lpos + 1;
      46          end until;
      47      key = .s. 1, 10, line;
      48      if  (lpos<10)  slen key = lpos;
      49        parmstr = ' 1 .=eject  2 .=list  3 .=punch  4 .=title '
      50            !! ' 5 .=zzyorg  6 .=member ';
dsv   61 .+mc     call stpc(key); $ convert to primary case.
      51      keycode = key .in. parmstr;
      52      if  (keycode)  keycode = digofchar((.ch. keycode-1, parmstr));
      53      if  (keycode = 0)  return;
      54      $   set lpos to index start of parameter string.
dsq  190      while isblank(linech(lpos));
      56          lpos = lpos + 1;
      57          if  (lpos>mccd) quit while;
      58          end while;
      59      if  (lpos>=mccd) lpos = 0;
      60
      61      slen parmstr = 0;
      62      if(keycode=2) parmstr = ' cod=01 inp=02 aut=03 ski=04 qua=05'
      63          .cc. ' lin=06 ref=07 res=10 dir=11 ';
      64      if(keycode=3) parmstr = ' def=08 exp=09 dir=11 ';
      65      if  (slen parmstr = 0 ! lpos = 0) go to endparmlist;
      66      prm = 6q------;  $ set - so will not find in parm code list.
      67      pgiven = 0; pvalue = 0;
      68      pl = 0;
      69      while 1;  $ process listed values until blank seen.
      70          c = linech(lpos);
      71          if  alphameric(c)  then
      72              if  pl < 5  then
      73                  pl = pl + 1; .ch. pl, prm = c;
      74                  end if;
      75          else  $ nonalphabetic character ends parameter.
      76              slen prm = pl;
      77              if  ('no' .in. prm) = 1  then  $ if disabling, remove 'no'
      78                  prmcopy = prm;
      79                  prm = 6q------;
      80                  do  i = 1 to pl-2;
      81                      .ch. i, prm = .ch. i+2, prmcopy;
      82                      end do;
      83                  slen prm = pl-2;
      84                  parmvalue = 0;  $ disable option.
      85              else  $ else enable option.
      86                  parmvalue = 1;
      87                  end if;
      88              slen prm = 4;
      89              .ch. 4, prm = 1r=;  $ use '=' to anchor place in lookup
dsv   62 .+mc         call stpc(prm); $ convert to primary case.
      90              i = prm .in. parmstr;  $ see if valid option.
      91              if  i  then  $ if option valid, extract code.
      92                  i = digofchar((.ch. i+4, parmstr))*10+
      93                      digofchar((.ch. i+5, parmstr));
      94                  .f. i, 1, pgiven = yes;  $ indicate option present.
      95                  .f. i, 1, pvalue = parmvalue;  $ set option.
      96                  end if;
      97              pl = 0;  prm = 6q------;
      98              end if;
      99
     100          lpos = lpos+1;
dsq  192          if  (isblank(c)) quit while;
     102          end while;
     103 /endparmlist/
     104      araptr = 0;  $ reset tok ara top.
     105      lexlist = no; genlist = no;  $ default is not to list cards
     106      go to l(keycode) in 1 to 6;
     107 /l(6)/   $ skip member definition line.
     108      go to retara;
     109 /l(1)/   $ process eject.
     110      l = 0;
     111      if  lpos then
     112          c = 1r0;  lpos = lpos-1;
     113          while numeric(c);  $ collect count.
     114              l = l*10 + digofchar(c);
     115              lpos = lpos + 1;  if (lpos>mccd)  quit while;
     116              c = .ch. lpos, prm;
     117              end while;
     118          end if;
     119
     120      if  (listinginput)  ejectlp(l);
     121      tokrwd = 0;  tokrtyp tokrwd = listejecttok;
     122      tokrlen tokrwd = l;
     123      araptr = 1;  ara(1) = tokrwd;
     124      go to retara;
     125 /l(3)/   $ process punch.
     126      if  (listignore) go to retara;  $ if should ignore, done
     127      lexlist = yes; genlist = yes;  $ we list punch cards
     128      listdir = .f. list_directive, 1, pvalue; $ set directive list valu
     129      if  .f. list_definitions, 1, pgiven then  $ change value
     130          punchdefine = .f. list_definitions, 1, pvalue;
     131          end if;
     132      if  .f. list_expansions,  1, pgiven then
     133          punchexpand = .f. list_expansions,  1, pvalue;
     134          end if;
     135      go to dircheck;  $ check for dir/nodir
     136 /l(2)/   $ process list.
     137      if  (listignore) go to retara; $ do nothing if ignoring
     138      resuming = .f. list_resume, 1, pvalue; $ get resume flag
     139      listdir = .f. list_directive, 1, pvalue; $ get directive list flag
     140      .f. list_resume,    1, pvalue = no; $ clear these
     141      .f. list_directive, 1, pvalue = no;
     142      if  resuming then  $ if resume, pop listing stack
     143          listnew = listprev(listprevptr);
dst   15          listprevptr = listprevptr - (listprevptr>1);
     145      else
     146          listnew = (listnow & ^pgiven) ! pvalue;  $ set new list value
     147          end if;
     148
     149      if  listnew ^= listnow  then  $ if change.
     150          do   i = 1 to numlistparms;
     151              j = .f. i, 1, listnew;
     152              l = .f. i, 1, listnow;
     153              if  j ^= l  then
     154                  lexlist = lexlist ! listval_ll listvals(i);
     155                  genlist = genlist ! listval_gl listvals(i);
     156                  if  listval_tf listvals(i) & tokwrt then
     157                      tokrwd = 0;
     158                      tokrtyp tokrwd = listcontroltok;
     159                      tokrlen tokrwd = i;
     160                      tokrlc  tokrwd = j;
     161                      araptr = araptr + 1;  ara(araptr) = tokrwd;
     162                      end if;
     163                  end if;
     164              end do;
     165          end if;
     166
     167      if  resuming = no  then  $ if not resume, save list word.
     168          if  listprevptr = listprevmax  then
     169              do  i = 3 to listprevmax;
     170                  listprev(i-1) = listprev(i);  end do;
     171          else
     172              listprevptr = listprevptr + 1;
     173              end if;
     174          listprev(listprevptr) = listnow;
     175          end if;
     176      listnow = listnew; $ set current value
     177
     178 /dircheck/  $ check for dir/nodir override
     179      if  .f. list_directive, 1, pgiven then  $ present
     180          lexlist = listdir; genlist = listdir;
     181          end if;
     182
     183      go to retara;
     184 /l(4)/   $ process title.
     185      l = 0;                 $ title length.
     186      if  (lpos=0)  go to dotitle;  $ avoid null title.
     187      $   check that first char is quote.
     188      c = linech(lpos);
     189      if  (c^=1r')  go to retara;
     190      while  1;
     191          lpos = lpos + 1;  if  (lpos>=(mccd-1))  quit while;
     192          c = linech(lpos);
     193          if  c = 1r'  then  $ if quote, see if interior or terminator.
     194              if  linech(lpos+1) = 1r'  then  $ if interior quote,
     195                  lpos = lpos + 1;  $ skip so add one quote to title.
     196              else  $ if terminator, end title.
     197                  quit while;
     198                  end if;
     199              end if;
     200          l = l + 1;  linech(l) = c;
     201          end while;
     202 /dotitle/
     203      $   convert null title to single blank to simplify read in gen.
     204      $   avoid null title to simplify gen processing.
     205      $   if first char of line could not be blank, would have to reset
     206      l = l + (l=0);
     207      slen line = l;
     208      if  (listinginput) call stitlr(subtitling, line);
     209      if  subtitling & listinginput  then  $ if subtitle, eject if listi
     210          ejectl;
     211          end if;
     212      subtitling = 1;
     213      tokrwd = 0;
     214      tokrtyp tokrwd = listtitletok;
     215      tokrlen tokrwd = l;
     216      ara(1) = tokrwd;  araptr = 1;
     217      l = (l-1)/cpw + 1;  $ convert length to word count.
     218      do  i = 1 to l;
     219          ara(araptr+i) = .f. lorg - i*ws, ws, line;
     220          end do;
     221      araptr = araptr + l;
     222      go to retara;
     223 /l(5)/   $   process 'zzyorg' setl library directive.
     224      if  (lpos=0)  go to retara;  $ if no parameter.
     225      genlist = yes;  lexlist = yes;  $ list this card.
     226      while lpos <= mccd;
     227          c = .ch. lpos, line;
dsw   17 .+mc     c = ctpc(c);  $ convert to primary case.
     228          if  alphabetic(c)  then  countzzy(lettercode(c)) = 0;
     229          else  quit while;  end if;
     230          lpos = lpos + 1;
     231          end while;
     232      go to retara;
     233 /retara/     $ write entries in ara to token file.
     234      do  i = 1 to araptr;
     235          tokout1(ara(i));
     236          end do;
     237      work = work & ^proc_work;  $ we dont have -lex- process this card
     238      work = work ! (list_work*listinginput);  $ set if list is now set
     239      if  (lexlist = no) work = work & ^list_work;
     240      if  (genlist = no) work = work & ^out_work;
     241      normwork = (normwork & ^list_work) ! (list_work*listinginput);
     242
     243      +* lorg = **  $ drop lorg macro.
     244      end subr lexdir;
       1 .=member hash
       2      subr hash;  $  adds token to scanner symbol table
       3
       4 $    the routine -hash- adds a token to the symbol table (ha).
       5 $    we then compute hash-code for token and see if it has already
       6 $    been entered in the symbol table.  if not, a new entry in the tabl
       7 $    table is build, and the symbolic name stored in the -names- ar
       8 $    array.
       9 $    hash performs the additional function of posting
      10 $    references to symbols if the cross-reference option has
      11 $    been raised.  in this case, references to names are collected.
      12
      13
      14      size  hashcode(ws);     $ hash-code computed
      15      size  i(ps);            $ do-loop index
      16      size  hashtokara(ws); dims hashtokara(1+maxtoklen/cpw); $
      17      size  haent(hasz);  $ ha(haptr)
      18      size  l(ps);
      19      size  rem(ps);          $ characters remaining in last word.
      20
      21 .+tallyhash      tally(tally_haprobes)  $ count ha searches
      22      hashlen = slen hashtok;  $ get length in characters
      23      if  (hashlen>maxtoklen)  hashlen = maxtoklen;
      24 .+ht.
      25      if  hashtrace  then
      26          tintl('hatrace len',hashlen) tintl('type',hashtyp)
      27          textl('symbol = ') textl(hashtok)
      28          end if;
      29 ..ht
      30      hashwords = (hashlen-1) / cpw;  $ number of extra words in item
      31      if  (hashlen=0)  hashwords = 0;
      32          $ blank fill last word in hashtok if necessary
      33      rem = cpw - (hashlen - hashwords*cpw);  $ no. of trailing chracter
      34      if  rem  then  $ if need blank fill.
      35          .f. hashtokorg -(hashwords+1)*ws, rem*cs, hashtok
      36              = blankword;
      37          end if;
      38 $    now copy words from sds-input hashtok into array of words.
      39 $    compute hash-code as exclusive-or of all input words, followed
      40 $    by exclusive-or of left and right halves, an
      41 $    take remainder modulo hash-table length.
      42      hashcode = .f. hashtokorg - ws, ws, hashtok;
      43      hashtokara(1) = .f. hashtokorg - ws, ws, hashtok; $ word 1
      44      do  i = 1 to hashwords;
      45          hashtokara(i+1) = .f. hashtokorg - (i+1)*ws, ws, hashtok;
      46          hashcode = hashcode .ex. .f. hashtokorg-(i+1)*ws, ws, hashtok;
      47          end do;
      48
      49      hashcode = .f. 1, ws/2, hashcode  .exor. .f. ws/2+1,ws/2,hashcode;
      50      haptr = mod(hashcode, haprime) + 1;
      51 $    examine table until find matching or unused entry
      52
      53 /probe/
      54 .+tallyhash      tally(tally_haentries) $ count entries seen
      55      if  (lexlen ha(haptr) ^= hashlen !  lextyp ha(haptr) ^= hashtyp)
      56          go to nomatch;
      57      if  (names(nameptr ha(haptr)) ^= hashtokara(1)) go to nomatch;
      58
      59      if  hashwords then  $ if something to check.
      60          l = nameptr ha(haptr) - 1;  $ set starting name pointer - 1.
      61          do  i = 2 to hashwords+1;  $ check the extra words.
      62              if  (names(l+i) ^= hashtokara(i))  go to nomatch;
      63              end do;
      64          end if;
      65      go to found;
      66
      67 /nomatch/
      68      if  halink ha(haptr)  then  $ if more in chain.
      69          haptr = halink ha(haptr);
      70          go to probe;
      71          end if;
      72
      73      if  (lextyp ha(haptr) = 0) go to addnew;  $ this is free.
      74
      75      do  hafree = hafree-1 to 1 by -1;  $ scan down from top.
      76          if  lextyp ha(hafree) = 0 then  $ found free entry.
      77              halink ha(haptr) = hafree;  $ link this one in.
      78 .+tallyhash  tally(tally_halinks)   $ count the link.
      79              haptr = hafree;  go to addnew;  $ go build entry.
      80              end if;
      81          end do;
      82
dso   32      call ermsg(20, 0, 0);  call lexexit;  $ ha is full.
      84
      85 /addnew/
      86      haused = haused + 1;  $ increment entries used count.
      87      haent = 0;  $ set ha entry to zero.
      88      lexlen haent = hashlen;  $ set length.
      89      lextyp haent = hashtyp;   $  set lexical type.
      90      nameptr haent = namesptr;  $ set pointer to -names-.
      91      ha(haptr) = haent;  $ set entry into table.
      92      namesptr = namesptr + hashwords;  $ set to new position - 1;
      93      countup(namesptr, namesmax, 'names');
      94      do  i = 1 to hashwords+1;  $ move in all words.
      95          names(namesptr+i-hashwords-2) = hashtokara(i);  $ move a word.
      96          end do;
      97
      98 /found/
      99 .+ht.
     100      if  (hashtrace=yes)  then
     101          tintl('hash code', haptr) endl
     102          end if;
     103 ..ht
     104 $    if just hashed name, update useage count, for subsequent use by
     105 $    detect.
     106      if  (hashtyp ^= nametok) return;  $ done if not name.
     107      if  litcod ha(haptr) = 0 then  $ have something more to do.
     108          if  (nuses ha(haptr) < suspi)
     109              nuses ha(haptr) = nuses ha(haptr) + 1;  $ count uses.
     110 .+cr.             $ cross reference.
     111          if  (isonxrf=no) return;
     112          if  (collectingrefs = no)  return;
     113          if  (initializing) return;  $ dont write ref for init.
     114          creftot = creftot + 1;
     115          crefent = 0;
     116          cref_ha crefent = haptr;
     117          cref_line crefent = icdno;  $ set line number.
     118          cref_macro crefent = (macorg ha(haptr) ^= 0);  $ macro state
     119          crefput(crefent);
     120 ..cr
     121          end if;
     122
     123      end subr hash;
     124      subr fivdec(n);  $ integer to sds converter
       1 .=member fivdec
       2      size  i(ps);  $ do-loop index
       3      size  j(ps);  $ remaining value to convert
       4      size  n(ps);
       5
       6      j = n;
       7      do  i = 5 to 1 by -1;
       8          fivdecara(i) = charofdig(mod(j, 10));
       9          j = j/10;
      10          end do;
      11
      12      end subr fivdec;
       1 .=member ibigr
       2      fnct ibigr(jarg, karg);  $ compare two symbols.
       3      size  jarg(ps), karg(ps);  $ ha indices of symbols.
       4      size  ibigr(1);
       5      size  jsym(sdstl), ksym(sdstl);  $ symbol strings to compare
       6      size  jlen(ps), klen(ps); size minlen(ps);
       7      size  jch(cs), kch(cs);  $  characters.
       8      size  i(ps);            $ loop index.
       9
      10      jch = .f. ws+1-cs, cs, names(nameptr ha(jarg));
      11      kch = .f. ws+1-cs, cs, names(nameptr ha(karg));
      12      if  jch ^= kch  then  $ if initial characters differ,
      13          ibigr = (jch > kch);  $ compare to get result.
      14          return;
      15          end if;
      16
      17      $   must examine rest of symbols, retrieve as sds and compare.
      18      getsym(jsym, jarg);  getsym(ksym, karg);
      19      jlen = slen jsym; klen = slen ksym;
      20      minlen = jlen; if  (klen < minlen) then minlen = klen; end if;
      21      ibigr=1;  $ assume j bigger
      22      do  i = 1 to minlen;
      23          jch = .ch. i, jsym;  kch = .ch. i, ksym;
      24          if  jch ^= kch  then
      25              ibigr = (jch > kch);
      26              return;
      27              end if;
      28          end do;
      29
      30      ibigr = (jlen > klen);  $
      31
      32      end fnct ibigr;
       1 .=member detect
       2      subr detect;  $  finds and lists suspicious variables
       3 $        detect lists 'suspicious' names, i.e., names which
       4 $    have been used less than 'suspi' times in the program.
       5      size  i(ps);  $ do-loop index
       6      size  ksym(sdstl);  $ string for name.
       7      size  lines(ps);  $ number of lines for list.
       8      size  m(ps);           $loop index.
       9      size  hapack(ps);  $ size of packed ha.
      10      size  top(ps);  $ loop indices
      11      size  targ(ps);
      12      size  temp(hasz);  $ temporary for swapping
      13      size  ibigr(1);   $ function to compare symbols.
      14
      15      hapack = 0;
      16      if  (dodetect=no) return;  $ check is sus vars list off
      17      do  i =  1 to  hadim;
      18          if  (nameptr ha(i) = 0) cont do;
      19          if  ((litcod ha(i))
      20              !(nuses ha(i) >= suspi)
      21              !(nuses ha(i) = 0)
      22              !(lextyp ha(i) ^= nametok)) cont do;
      23          hapack = hapack + 1;  ha(hapack) = ha(i);
      24          end do;
      25
      26      $ if no suspicious names, return
      27      if  (hapack = 0)  return;  $ if no suspicious names.
      28
      29      +*  swap(a,b) = $ macro for swapping, common sort operation
      30          temp = ha(a); ha(a) = ha(b); ha(b) = temp; **
      31
      32      do  i = 2 to hapack; $ make into heap, i is parent.
      33          m = i;
      34          while  m>1;  $ examine parents in turn
      35              if  ibigr(m/2, m)  quit while; $ if parent no smaller,
      36              swap(m,m/2); $ promote large child
      37              m = m/2;
      38              end while;
      39          end do i;
      40
      41      do  top = hapack to 2 by -1; $ sort subtrees in turn
      42          swap(1,top);  $ extract largest element
      43          m = 1;  $$ force remaining subtree to be heap
      44          while  m*2 < top;
      45              if  ibigr(m*2+1, m*2) & (m*2+1 < top)
      46                  then  targ = m*2+1;
      47                  else  targ = m*2;  end if;
      48              if  ibigr(targ,m)  then
      49                  swap(m, targ); $ child too big, so exchange
      50              else  quit while;  end if;
      51              m = targ;  $ move to subtree of largest child
      52              end while m;
      53          end do top;
      54
      55      macdrop(swap)
      56      textl(' ') endl  $ blank line
      57      textl(' * * * suspicious names used ')
      58      if  suspi = 2 then  $ print shorter message.
      59          textl('only once:')
      60      else  $ print long message.
      61          textl('less than') intl(suspi) textl(' times:')
      62          end if;
      63      endl
      64      lines = (hapack+5)/6;   $ number of lines.
      65      do  m = 1 to lines;
      66          i = m;
      67          while i <= hapack;
      68              getsym(ksym, i);
      69              textl(ksym);  $ print symbol
      70              skipl(21-slen ksym)
      71              i = i + lines;
      72              end while;
      73          endl
      74          end do;
      75      endl  $ flushing last few names
      76
      77      end subr detect;
       1 .=member pflshr
       2      subr pflshr(wd);   $ lexical punch routine.
       3      size  wd(ws);   $ ha index of token to punch.
       4      size  i(ps), j(ps);    $ temporaries and counters.
       5
       6      +*  puncha(c) =   $ macro to punch a character.
       7          punchpos = punchpos+1;  $ advance column pointer.
       8          if  (punchpos > mccd) call pncr;  $ flush card if too long.
       9          punchbuf(punchpos) = c;  $ insert character.
      10          **
      11
      12      $   first, open the punch file if not previously opened.
      13      if  punchopened = no then  $ must open punch file.
      14          call opensio(punchfile, iorc, access_put, punchfilename, 80,j,
      15              0, 0);    $ open the punch file.
      16          punchopened = yes;  $ show file is opened.
      17          punhold1 = 0;  punhold2 = 0;  punlastlt = 0;
      18          do  i = 1 to 80;  punchbuf(i) = 1r ; end do;  $ clear buffer.
      19          punchpos = 6;   $ start punching at column 7.
      20          end if;
      21
      22      $   now see if this is an end-of-job call.
      23      if  wd < 0 then  $ this is end-of-job call.
      24          $   see if anything is in our 'hold' buffers.  if so, flush th
      25          if  punhold1 = ihpl then  $ flush this.
      26              puncha(1r+)
      27          elseif  punhold1 = ihst then
      28              puncha(1r*)
      29          elseif  punhold1 = ihsl then
      30              puncha(1r/)
      31              if  punhold2 then  $ second token held.
      32                  if  punchpos+lexlen ha(punhold2) > 70 then
      33                      call pncr;  punchpos = 10;
      34                      end if;
      35
      36                  do  i = 1 to lexlen ha(punhold2);  $ punch symbol.
      37                      puncha(isymc(punhold2, i))
      38                      end do;
      39                  end if;
      40              end if;
      41
      42          call pncr;  $ flush card.
      43          call clossio(punchfile, iorc);  $ close punch file.
      44          return;   $ done in end case.
      45          end if;
      46
      47
      48      $   this is the normal case where we have a symbol to punch.
      49      $   first see if this will cause a special case.
      50      if  punhold1 = ihpl then  $ last was +.
      51          if  wd = ihst then  $ makes this +*
      52              call pncr;  $ this starts new card.
      53              punchpos = 6;   $ start at column 7.
      54              puncha(1r+)  puncha(1r*)  puncha(1r )  puncha(1r )
      55              punhold1 = 0;  punlastlt = 0;  $ reset.
      56              return;    $ done with this case.
      57              end if;
      58
      59          $   we are here if we have a + that if not followed by
      60          $   a *.  in this case we must flush the +.
      61          puncha(1r+)  punhold1 = 0;  punlastlt= 0;
      62
      63      elseif  punhold1 = ihst then  $ last token was *.
      64          if  wd = ihst then  $ this was **.
      65              if  (punchpos < 9) punchpos = 9;  $ move to offset.
      66              puncha(1r )  puncha(1r*)  puncha(1r*)
      67              call pncr;  punchpos = 6;  $ this ends card.
      68              punhold1 = 0;  punlastlt = 0;  $ reset.
      69              return;  $ done in this case.
      70              end if;
      71
      72          $   we are here if we have a * that is not followed by
      73          $   another *.  in this case we must flush the *.
      74          puncha(1r*)  punhold1 = 0;  punlastlt = 0;
      75
      76      elseif  punhold1 = ihsl then  $ last token was /.
      77          if  punhold2 then  $ there was a name held also.
      78              if  wd = ihsl then  $ this was label definition.
      79                  call pncr;  $ start new card.
      80                  punchpos = 0;  $ reset position.
      81                  puncha(1r )  puncha(1r/)
      82                  do  i = 1 to lexlen ha(punhold2);  $ output name.
      83                      puncha(isymc(punhold2, i))
      84                      end do;
      85
      86                  puncha(1r/)
      87                  call pncr;  $ this is alone on a card.
      88                  punchpos = 0;  $ reset position.
      89                  punhold1 = 0;  punhold2 = 0;  punlastlt = 0;
      90                  return;  $ done in this case.
      91                  end if;
      92
      93              $   in this case we have  /name  and no /.
      94              puncha(1r/)   $ punch out the /.
      95              if  lexlen ha(punhold2)+punchpos > 70 then
      96                  call pncr;  punchpos = 10;
      97                  end if;
      98
      99              do  i = 1 to lexlen ha(punhold2);  $ punch name.
     100                  puncha(isymc(punhold2, i))
     101                  end do;
     102
     103              punhold1 = 0;  punhold2 = 0;  punlastlt = nametok;
     104
     105          else  $ this is / and nothing else held.
     106              if  lextyp ha(wd) = nametok then  $ /name
     107                  punhold2 = wd;  $ hold this token.
     108                  return;   $ done in this case.
     109                  end if;
     110
     111              $   else we must flush the /.
     112              puncha(1r/)  punhold1 = 0;  punlastlt = 0;
     113              end if;
     114          end if;
     115
     116
     117      $   now see if this symbol should be held.
     118      if  wd = ihpl ! wd = ihst ! wd = ihsl then  $ hold +*/.
     119          punhold1 = wd;  return;  $ hold and return.
     120          end if;
     121
     122      $   now we will punch symbol.  first ensure it will fit on card.
     123      if  lexlen ha(wd)+punchpos > 70 then  $ will not fit.
     124          call pncr;  punchpos = 10;  punlastlt = 0;
     125          end if;
     126
     127      $   now if this token and last token were names or integers,
     128      $   insert a blank.
     129      if  (punlastlt = nametok ! punlastlt = dectok) & (lextyp ha(wd) =
     130          nametok ! lextyp ha(wd) = dectok) then
     131          puncha(1r )
     132          end if;
     133
     134      punlastlt = lextyp ha(wd);  $ now set lexical type.
     135
     136      $   now actually punch token.
     137      if  punlastlt = rztok ! punlastlt = sstok then  $ punch length.
     138          call fivdec(lexlen ha(wd));  $ get length.
     139          do  i = 1 to 5;  $ output length.
     140              if  fivdecara(i)^=1r0 then puncha(fivdecara(i));  end if;
     141              end do;
     142
     143          if punlastlt = rztok then puncha(1rr) else puncha(1rs) end if;
     144
     145      elseif  punlastlt = stringtok then  $ this is string.
     146          puncha(1r')
     147          end if;
     148
     149      do  i = 1 to lexlen ha(wd);  $ output actual token.
     150          puncha(isymc(wd, i))  $ punch a character.
     151          if  punlastlt = stringtok & isymc(wd, i) = 1r' then
     152              puncha(1r')  $ double the quotes.
     153              end if;
     154          end do;
     155
     156      if punlastlt = stringtok then  puncha(1r')  end if;
     157
     158      $   if this token is a semicolon or a 'then', flush this card
     159      $   unless it is almost empty.
     160      if  wd = ihsemi ! litcod ha(wd) = 71 then
     161          if  punchpos > 35 then
     162              call pncr;  punchpos = 6;  $ start a new card.
     163          else   $ a fairly empty card.
     164              puncha(1r )  puncha(1r )
     165              end if;
     166
     167          punlastlt = 0;  $ no space needed next time.
     168          end if;
     169
     170      macdrop(puncha)
     171      end subr pflshr;
       1 .=member pncr
       2      subr pncr;  $ actually punch the card.
       3      size  i(ps);    $ temporary.
       4
       5      until  yes;  $ quit if must punch the card.
       6          if  (punchpos > 6) quit until;
       7          do  i = 1 to punchpos;
       8              if  (punchbuf(i) ^= 1r ) quit until;
       9              end do;
      10
      11          return;  $ else this would be a blank card.
      12          end until;
      13
      14      call fivdec(icdno);  $ convert card number.
      15      punchbuf(75) = 1rp;  $ set id flag.
      16      do  i = 1 to 5;  punchbuf(75+i) = fivdecara(i);  end do;
      17      call putcsio(punchfile, iorc, punchbuf, 1, 0);  $ punch card.
      18      do  i = 1 to 80;  punchbuf(i) = 1r ;  end do;
      19      punchpos = 0;  $ start at start of next card.
      20
      21      end subr pncr;
       1 .=member ermsg
       2      subr ermsg(ernum, par1, par2); $ error message printer
       3 $        ermsg is called to list warning or error message.
       4 $    ernum is error number, and par1 and par2 are optional
       5 $    parameters whose meaning depends on ernum; typically
       6 $    they are ha indices to tokens related to error.
       7 $    a special call to givecr is made to list the current line
       8 $    if it has not yet been listed, and ertlist is called to
       9 $    list the last few tokens seen before the error.
      10
      11      +*  ermsgmax = 33 **  $ max. number of error messages
      12      size  ermsgwarn(ermsgmax);  $ flags warnings
      13      data ermsgwarn = 1b'000 00010 00000 00000 00001 10000 00000';
dso   33      size  ernum(10), par1(ws), par2(ws);
      15      size  dummyarg(ps);  $ dummy argument for givecr
      16
      17      ejectlp(4);  $ ensure whole message on one page
      18
      19      terml((.f. ernum, 1, ermsgwarn) = no)
      20      errecho = yes;  $ list current card if not yet listed
      21      call givecr(dummyarg);
      22      skipl(7+nowc) charl(1r$) endl
      23
      24      if  .f. ernum, 1, ermsgwarn  then  $ if warning
dsq  193 .+s10    warn_s10;  $ flag warning message for s10.
      25          textl(warning_notice)
      26          nwarnings = nwarnings + 1;
      27      else
dsq  194 .+s10    error_s10;  $ flag error message for s10.
      28          textl(error_notice)
      29          nerrors = nerrors +1;
      30          end if;
      31
      32      go to e(ernum) in 1 to 33;
      33 /e(1)/
      34      textl('macro ''') tokl(par1)
      35      textl(''' called with no arguments.') go to errtn;
      36 /e(2)/
      37      textl('macro ''') tokl(par1)
      38      textl(''' called with too few arguments.')  go to errtn;
      39 /e(3)/
      40      textl('macro ''')  tokl(par1)
      41      textl(''' called with too many arguments')  go to errtn;
      42 /e(4)/
      43      textl('macro close occurs outside macro definition.') go to errtn;
      44 /e(5)/
dsy   20 $ error 5 - illformed iset parameter
dsy   21       textl('illegal iset character ''')
dsy   22       charl(par1)  charl(1r')  go to errtn;
      45 /e(6)/
dsy   23 $ error 6 - illformed name after .+set
dsy   24       textl('expect name after .+set ') go to errtn;
      46 /e(7)/
      47      go to notext;
      48 /e(8)/
      49      textl('illegal symbol ''')  tokl(par1)
      50      textl(''' follows macro opening.')  go to errtn;
      51 /e(9)/
      52      textl('illegal symbol ''')  tokl(par1)
      53      textl(''' follows macro name ''') tokl(par2) textl('''.')
      54      go to errtn;
      55 /e(10)/
dsz   13      nwarnings = nwarnings - 1; $ do not include this in warning count.
      56      textl('name ''')  tokl(par1)
      57      textl(''' with prior usage is being designated as a macro.')
      58      endl return;
      59 /e(11)/
      60      textl('macro ''')  tokl(par1)
      61      textl(''' has been redefined.') endl return;
      62 /e(12)/
      63      textl('macro definition opened before required close.  ')
      64      textl('possibly missed earlier termination.')  go to errtn;
      65 /e(13)/
      66      textl('macro ''') tokl(par1) textl(''' occurs within itself.')
      67      go to errtn;
      68 /e(14)/
      69      go to notext;
      70 /e(15)/
      71      textl('no ''='' after argument list for macro ''') tokl(par1)
      72      textl('''.') go to errtn;
      73 /e(16)/
      74      textl('parameter list for macro ''')  tokl(par1)
      75      textl(''' mispunctuated..') go to errtn;
      76 /e(17)/
      77      textl('illegal repetition of name ''') tokl(par1) textl('''  ')
      78      textl('in argument for macro ''')  tokl(par2)  textl('''.')
      79      go to errtn;
      80 /e(18)/
      81      textl('maximum length of')  intl(par1)
      82      textl(' characters in string exceeded.')  go to errtn;
      83 /e(19)/
      84      textl('token longer than') intl(par1) textl(' characters.')
      85      go to errtn;
      86 /e(20)/
      87      textl('hash table overflow.')  go to errtn;
      88 /e(21)/
      89      textl('excessive macro nesting or recursion.') go to errtn;
      90 /e(22)/
dsz   14      textl(' expect ** ending prior macro definition')
dsz   15      go to errtn;
      91 /e(23)/
      92 /e(24)/
      93 /e(25)/
      94      go to notext;
      95 /e(26)/
      96      textl('missing or illegal real exponent')  go to errtn;
      97 /e(27)/
      98      textl('/*   occurs inside   /* ... */   comment') endl return;
      99 /e(28)/
     100      textl('excessively long macro argument list.  probably missing ')
     101      textl(''')'' in arguments to ''') tokl(par1) textl(''' at line ')
     102      intl(par2) textl('.') go to errtn;
     103 /e(29)/
     104 /e(30)/
     105 /e(31)/
     106      go to notext;
     107 /e(32)/
     108      textl('illegal character''') charl(par1)
     109      textl(''' in bit constant.');  go to errtn;
     110 /e(33)/
     111      textl('bit constant too long.');  go to errtn;
     112 /notext/  $ error without identifying text.
     113      textl('error number ') intl(ernum)  endl
     114      textl(' no text supplied, traceback follows.') endl
     115      call ltlxtr;
     116 /errtn/
     117      call ertlist;  $ list last few tokens
     118      if  ernum = 28 then  $ special text for this error.
dsq  195 .+s10    warn_s10;  $ flag warning message for s10.
     119          textl(warning_notice)  textl('compilation continuing but ')
     120          textl('tokens from ''') tokl(par1) textl(''' at line ')
     121          intl(par2) textl(' to last token listed have been skipped.')
     122          endl
     123          end if;
     124
     125      if  nerrors>lelvalue  then  $ if error limit exceeded.
dsq  196 .+s10    error_s10;  $ flag error message for s10.
     126          textl('**** lexical error limit of') intl(lelvalue)
     127          textl(' exceeded, scan aborted.') endl
     128          terml(no); call lexexit;
     129          end if;
     130      terml(no);  $ end of terminal file output
     131
     132      end subr ermsg;
       1 .=member ertlist
       2      subr ertlist;  $ list tokens if error detected
       3      size  inp(ps);
       4
       5      inp = lsvtkp + 1;  $ position of last 0 word put in lsvtk
       6      endl skipl(15) textl('last few tokens: ')
       7      while  lsvtk(inp+1);  $ loop until next zero found
       8          tokl(lsvtk(inp+1));  charl(1r );  $ write out token
       9          inp = (inp+1) & lsvtkz;  $ step to next
      10          end while;
      11      endl endl
      12
      13      end subr ertlist;
       1 .=member toklr
       2      subr toklr(hap);  $ list token given hash code
       3      size  hap(ps);  $  hash code of token to ljst
       4      size  np(ps);  $ pointer to names array for token
       5      size  cp(ps);  $ character position during list
       6      size  i(ps);  $ do loop index
       7
       8      np = nameptr ha(hap);
       9      cp = ws+1;  $ starting character pos
      10      do  i = 1 to lexlen ha(hap);  $ list characters in turn
      11          cp = cp - cs;  $ move to next character
      12          charl((.f. cp, cs, names(np)))  $ list character
      13          if  cp = 1  then  cp=ws+1; np=np+1;  end if;
      14          end do;
      15
      16      end subr toklr;
      17
       1 .=member ltoflo
       2      subr ltoflo(pt, lim, msg);  $  called if scanner array overflow
       3      size  pt(ps);  $ var to increment
       4      size  lim(ps);  $  maximum allowed value for -pt-
       5      size  msg(ws+1);  $  diagnostic test passed if overflow occurs
       6      size  dummyarg(ps);
       7
       8      terml(yes);  $ send this to terminal file
       9      endl  endl
dsq  197 .+s10    error_s10;  $ flag error message for s10.
      10      textl(error_notice)
      11      textl('overflow of scanner array ') textl(msg)
      12      tintl(' ptr',pt) tintl('limit',lim) endl
      13 $    echo last input line seen.
      14      textl(' next line is last line processed before overflow.')endl
      15      errecho = yes;  call givecr(dummyarg);
      16      call ltlxtr; $ give trace back chain
      17      terml(no); call lexexit;
      18      end subr ltoflo;
       1 .=member lexexit
       2      subr lexexit; $ exit routine - prints statistics
       3 $        lexexit is called to end the scan, and proceeds as follows -
       4 $    1.  the cross-reference name buffer isbuf is flushed
       5 $            if cross-reference list being generated, and final
       6 $            action is taken.
       7 $    2.  the token file buffer is flushed if any tokens remain,
       8 $            and the end-file token is sent out.
       9 $    3.  scanner statistics are collected and listed, giving the
      10 $            structure of ha-table, macro usage, etc.
      11 $    4.  optionally, a list of machine-dependent constants is
      12 $            listed, to aid in production of portable software.
      13 $    5.  error count is output, and abort is generated
      14 $            if user so requests abort on errors.
      15 $    6.  finally, lexexit exits to the routine ltlterm,
      16 $            which initiates the generator phase.
      17
      18      size  hats(ps);  dims hats(20); data hats = 0(20); $ token types.
      19      size  hat(ps);  $ ha index.
      20      size  hatzz(ps);  data hatzz=0;  $ number of zz-type names.
      21      size  hap(ps);          $ ha pointer
      22      size  halt(ps);  $ lex type of ha entry
      23      size  haln(ps);         $ lex length of ha entry
      24      size  i(ps);  $ do loop index
dsv   63      size  termcode(ws);     $ termination code.
      25 .+s66.   $ to pass count to root.
      26      nameset lexcard;
      27          size  cardtot(ps);  $ no of cards read, used by driver routine
      28          end nameset lexcard;
      29      cardtot = icdno; $ pass total number of cards to driver routine
      30 ..s66
      31      skipl(1) endl $ blank line
      32      call clsinc; $ close the input file
      33
      34 $    now close the punch file it was opened, first call pflshr
      35 $    with special end of job code, and then close file
      36      if  punchopened  then
      37          call pflshr(-1);
      38          call clossio(punchfile, iorc);
      39          end if;
      40
      41      if  tokwrt  then
      42          tokrwd = 0;
      43          tokrtyp tokrwd = tokreof;  $ build eof token
      44          tokrlen tokrwd = 0;
      45          tokout1(tokrwd);
      46          if  tokrbufp  then  $ flush token buffer
      47              call wtrwsio(tokenfile, iorc, tokrbuf, 1, tokrbuflim);
      48              $ write entire buffer, gen phase will detect special eof t
      49              $ token code to determine true end of data
      50              end if;
      51          call clossio(tokenfile, iorc);  $ close token file.
      52          end if;
      53
      54      endl
      55      if  (lcs_opt=no) go to endofstatistics;
      56      $   list lexical scan statistics.
      57      call stitlr(1, 'statistics for lexical scan.'); ejectlp(20);
      58      textl('statistics for lexical scan.') endl
      59 .+tallycomments.  $ if requested, give comment statistics
      60      textl('source has ') intl(icdno) textl(' lines, with ')
      61      intl(tallypl1) textl(' pl/1 comments, and ') intl(tallyeol)
      62      textl(' $-style comments.') endl
      63 ..tallycomments
      64 .+tallytokens.  $ if requested, give token statistics
      65      textl('scanner detected ') intlp(tallytrue, 8)
      66      textl(' tokens (') intlp(tallyimtok, 8) textl(' immediate).')
      67      intlp(tallyparse, 8) textl(' tokens sent to parser.') endl
      68      textl('source contains ') intlp(tallyblank,8)
      69      textl(' words of blanks.')  endl
      70 ..tallytokens
      71 .+tallyhash.  $ if requested, list hash statistics
      72      textl('symbol table searched') intlp(tally_haprobes, 8)
      73      textl(' times;') intlp(tally_haentries,8)
      74      textl(' entries examined. ')
      75      if  tally_halinks then intl(tally_halinks)textl(' links.') end if;
      76      endl
      77 ..tallyhash
     100      if  mtptr  then
     101      textl('used ') intl(mtptr) textl(' of ') intl(mtlim)
     102          textl(' entries in macro definition table.') endl
     106      end if;
     107
     108      textl('used ') intl(haused) textl(' of ') intl(hadim)
     109          textl(' entries in symbol table.') endl
     110      textl('used ') intl(namesptr) textl(' of ') intl(namesmax)
     111          textl(' entries in names array.') endl
     112 $    list ha entries by tpye
     113      do  i =  1 to  hadim;
     114          if  (nameptr ha(i)=0) cont do;
     115          hat = lextyp ha(i);
     116          hats(hat) = hats(hat) + 1;
     117          if  (hat  ^= nametok) cont do;
     118     $    count names beginning with -zz-
     119          if  (isymc(i, 1)  ^= 1rz) cont do;
     120          if  (isymc(i,2)  ^= 1rz) cont do;
     121          hatzz = hatzz + 1;
     122          end do;
     123      endl textl('symbol table composition') endl
     124      skipl(5)
     125      textl(' name   zz-name   special    dot op   decimal      ')
     126      textl('real       bit    string         r         s')
     127      endl
     128      intlp(hats(nametok),10)  intlp(hatzz,10)
     129      intlp(hats(spectok),10)  intlp(hats(optok),10)
     130      intlp(hats(dectok), 10) intlp(hats(realtok), 10)
     131      intlp(hats(bittok), 10)
     132      intlp(hats(stringtok),10)  intlp(hats(rztok),10)
     133      intlp(hats(sstok),10)
     134      endl endl endl
     135
     136
dst   16 .+mdc.
     137      if  (mdclist = 0) go to endmdclist;
     138      textl('machine dependent constants:')   endl
     139      do  hap =  1 to  hadim;  $ look at ha
     140          $   long r or any s constant.s are machine-dependant
     141          if  (nameptr ha(hap) = 0) cont do;  $ ignore empty entries
     142          halt = lextyp ha(hap); haln = lexlen ha(hap); $ get type and l
     143          if  (halt=rztok & haln > 1) ! halt = sstok then
     144              intl(haln)
     145              if  halt=rztok then  charl(1rr) else charl(1rs) end if;
     146              do  i =  1 to  haln; charl(isymc(hap,i)); end do; $ output
     147              textl('    ')
     148              end if;
     149          end do;
     150      endl
     151 /endmdclist/
dst   17 ..mdc
     152
     153 .+mp.        $ here to list values of active zzy counters.
     154      size  nzzy(ps);       $ counter.
     155      nzzy = 0;
     156      do  i = 1 to 27;  $ find active zzy counters.
     157          if  countzzy(i)  then  nzzy = i;  quit do;  end if;
     158          end do;
     159      if  nzzy  then  $ if any active, list values.
     160          endl  textl('final values of active zzy counters: ')
     161          do  i = nzzy to 27;
     162              nzzy = countzzy(i);
     163              if  nzzy  then  $ if active.
     164                  textl('zzy')
     165                  charl((.ch. i, 'abcdefghijklmnopqrstuvwxyz_'))
     166                  textl(' = ')  intl(nzzy)  textl('   ')
     167                  end if;
     168              end do;
     169          endl
     170          end if;
     171 ..mp
     172
     173 /endofstatistics/
     174
     175 .+cr.
     176      size  nametot(ps);  $ number of names
     177      size  nptr(ps), nc(ps),  j(ps);
     178      if  isonxrf  then  $ if cross reference on, complete ref. file.
     179          crefput(0);  $ mark end of references.
     180          if  crbuffptr  then  $ flush buffer if not empty
     181              call wtrwsio(crfile, iorc, crbuff, 1, crbuffmax);
     182              end if;
     183          call clossio(crfile, iorc);  $ close reference file 1.
     184          call crfnam(crfilename, crfileparm, 2);
     185          call opensio(crfile, iorc, access_write, crfilename,
     186              0, i, 0, 0);
     187          crbuffptr = 0;
     188          crefput(creftot);
     189          crefput(icdno);  $ last card number.
     190          crefput(hadim);
     191          $  determine space needed for names.
     192          nametot = 0;
     193          do  i = 1 to hadim;
     194              if  (lextyp ha(i) ^= nametok)  cont do;
     195              nptr = nameptr ha(i);
     196              if  nptr  then  $ if name, get length
     197                  nc = lexlen ha(i);
     198                  nametot = nametot + (nc + (cpw-1))/cpw;
     199                  end if;
     200              end do;
     201          crefput(nametot);  $ indicate space needed for names.
     202
     203          do  i = 1 to hadim;
     204              if  (lextyp ha(i) ^= nametok)  cont do;
     205              crefput(i);
     206              nc = lexlen ha(i);
     207              crefput(nc);
     208              nptr = nameptr ha(i) - 1;
     209              $  write out name, packing chars into ref. size.
     210              do  j = 1 to (nc + (cpw-1))/cpw;
     211                  crefput(names(nptr+j));
     212                  end do;
     213              end do;
     214          crefput(0);  $ indicate end of ha.
     215
     216          if  crbuffptr  then
     217              call wtrwsio(crfile, iorc, crbuff, 1, crbuffmax);
     218              end if;
     219          call clossio(crfile, iorc);  $ close reference file 2.
     220          end if;
     221 ..cr
     222      call detect;
     223
     224      if  nwarnings  then  $ if warnings encountered.
dsq  198 .+s10    warn_s10;  $ flag warning message for s10.
     225          intl(nwarnings) textl(' warnings issued.')  endl
     226          end if;
     227      if  nerrors  then  $ if errors detected.
     228          terml(yes)
dsq  199 .+s10    error_s10;  $ flag error message for s10.
     229          textl('scan detected') intl(nerrors)
     230          textl(' lexical errors.')   endl
     234          end if;
     235
     236      $   fatal if no input lines read.
     237      if  icdno =  0  then
dsq  200          terml(yes)
dsq  201 .+s10    error_s10;  $ flag error message for s10.
dsq  202          textl('no input lines - fatal error.') endl
     239          terml(no)
     240          exitcode = yes;  $ force fatal termination.
     241          end if;
     242
     243      if  exitcode then  $ if abnormal termination
dsq  203          terml(yes)
dsq  204 .+s10    error_s10;  $ flag error message for s10.
dsq  205          textl('abnormal scanner termination') endl
     245          terml(no); call clsterm;
     246          call ltlfin(1, 1);  $ abnormal termination.
     247          end if;
     248
     249      if  tokwrt = no  then
     250          textl('no token file.')
     251          termlex = yes;  $ end compilation.
     252          end if;
     253
     254      endl  endl
     255      call clsterm;
dsv   64
dsv   65 $    determine termination code.
dsv   66
dsv   67      termcode = 0;
dsv   68      if  (nwarnings)  termcode = 4;
dsv   69      if  (nerrors)  termcode = 8;
dsv   70
     256      if  termlex  then  $ if lex phase terminates compilation.
     257          textl('end of compilation.')  endl
dsv   71          call ltlfin(0, termcode);
     259      else  $ if continuing to gen phase.
dsv   72          call ltlterm(1, termcode);
     261          end if;
     262
     263      end subr lexexit;
« 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: