Personal tools
You are here: Home Projects SETL SETL Source code PRS: Lexical scanner, macro processor, and parser; first pass of the SETL compiler.
Document Actions

PRS: Lexical scanner, macro processor, and parser; first pass of the SETL compiler.

by Paul McJones last modified 2021-03-18 20:22

PRS: Lexical scanner, macro processor, and parser; first pass of the SETL compiler. stlprs.opl

       1 .=member intro
       2$           ssssssss   eeeeeeeeee  tttttttttt  ll
       3$          ssssssssss  eeeeeeeeee  tttttttttt  ll
       4$          ss      ss  ee              tt      ll
       5$          ss          ee              tt      ll
       6$          sssssssss   eeeeee          tt      ll
       7$           sssssssss  eeeeee          tt      ll
       8$                  ss  ee              tt      ll
       9$          ss      ss  ee              tt      ll
      10$          ssssssssss  eeeeeeeee       tt      llllllllll
      11$           ssssssss   eeeeeeeee       tt      llllllllll
      12$
      13$
      14$                ppppppppp   rrrrrrrrr    ssssssss
      15$                pppppppppp  rrrrrrrrrr  ssssssssss
      16$                pp      pp  rr      rr  ss      ss
      17$                pp      pp  rr      rr  ss
      18$                pppppppppp  rrrrrrrrrr  sssssssss
      19$                ppppppppp   rrrrrrrrr    sssssssss
      20$                pp          rr   rr             ss
      21$                pp          rr    rr    ss      ss
      22$                pp          rr     rr   ssssssssss
      23$                pp          rr      rr   ssssssss
      24$
      25$
      26$                 t h e    s e t l    p a r s e r
      27$
      28$       this software is part of the setl programming system
      29$                address queries and comments to
      30$
      31$                          setl project
      32$                 department of computer science
      33$                      new york university
      34$           courant institute of mathematical sciences
      35$                       251 mercer street
      36$                      new york, ny  10012
      37$
      38
      39
      40$ this file contains the source for the first phase of the setl
      41$ compiler.  this phase consists of a parser, macro processor,
      42$ and lexical scanner.  its output is a symbol table and a reversed
      43$ polish string.
      44$
      45$ the parser is by far the simplest of the three sections.
      46$ the setl grammar is written in an extended bnf which can
      47$ be viewed as an assembly language for some abstract
      48$ parsing machine.  this assembly language is turned into
      49$ interpreteble code by the utility program 'syn', and
      50$ interpreted by the parser.
      51$
      52$ the parser consists of an interpreter called 'parse' and
      53$ several small auxilliary routines.
      54$
      55$ the scanner is also quite simple. it consists of a single
      56$ routine called 'trulex' which returns the next token from the
      57$ input stream.
      58$
      59$ the macro processor is relatively complex; the rest of this
      60$ section will concentrate on its design.
      61
      62$ the macro processor consists of three hierarchical routines.
      63$ each of these routines can be viewed from the outside as
      64$ a black box which obtains a token from some lower level routine
      65$ and returns it. from above, these routines seem like a garden
      66$ variety lexical scanner. in actuality they intercept certain
      67$ tokens passed to them in order to expand macros and absorb
      68$ macro definitions.
      69$
      70$ the three routines are:
      71$
      72$ 1. lexscan
      73$
      74$    this is the top level routine of the macro processor.
      75$    each time it is called, it returns a token from a lower
      76$    level routine. before returning a token, it checks
      77$    whether the token is a macro. if so, it initializes the
      78$    expansion of the macro and requests another token. it
      79$    returns the first token which is not a macro.
      80$
      81$ 2. absorb
      82$
      83$    this is the second level routine of the macro processor.
      84$    it passes along tokens from the routine below it, looking
      85$    for occurrences of 'macro' and 'drop'. each time it sees
      86$    one of these it makes a detour to process a macro drop
      87$    or definition.
      88$
      89$ 3. expand
      90$
      91$    this is the bottom level routine of the macro processor.
      92$    it checks whether any macros are currently being expanded.
      93$    if so, it returns the next word of macro text; otherwise
      94$    it obtains a token from trulex.
      95
      96$ the macro processor uses three global data structures:
      97$
      98$ 1. mtab:
      99$
     100$    this is an array used to store macro text. each word of
     101$    mtab represents a single token of macro text. there are
     102$    three types of macro text entries:
     103$
     104$    a. simple text
     105$
     106$       a simple text entry is represented by a symbol table
     107$       pointer.
     108$
     109$    b. user supplied arguments
     110$
     111$       the i-th user supplied argument is represented by
     112$       i+bias_user. bias_user is a bias used to distinguish
     113$       user supplied arguments from plain text.
     114$
     115$    c. generated arguments
     116$
     117$       generated arguments are names which are supplied by the
     118$       compiler during each macro expansion. the first time
     119$       we see each generated argument in a new expansion, we
     120$       generate a new name for it; the next time we see it
     121$       we supply the old name.
     122$
     123$       generated arguments are represented in two forms:
     124$
     125$       i+bias_gen1:  first occurrence of i-th generated argument
     126$       i+bias_gen2:  any other occurrence of i-th generated arg.
     127$
     128$    the various biases are arranged as follows:
     129$
     130$    bias_user = dimension of symbol table + 1.
     131$    bias_gen1 = bias_user + 100
     132$    bias_gen2 = bias_gen1 + 100
     133
     134$    the text for each macro consists of a series of mtab entries
     135$    followed by a zero entry. if 'm' is a macro then 'morg(m)'
     136$    gives its first entry in mtab.
     137$
     138$ 2. astack
     139$
     140$    astack is an array used to hold actual arguments of macros
     141$    currently being expanded. each argument can consist of a
     142$    series of tokens. its corresponding astack entry consists
     143$    of a series of symbol table pointers followed by a zero word.
     144$
     145$ 3. mstack
     146$
     147$    mstack is a stack used to control recursion during macro
     148$    expansion. we associate a series of mstack entries, known
     149$    as a stack frame, with each macro we are in the process of
     150$    expanding.
     151
     152$    each stack frame is organized as follows:
     153$
     154$    first word:    points to next word of macro text
     155$    second word:   gives number of arguments
     156$    i+2 nd word:   gives pointer to start of i-th argument in astack
     157$
     158$    stack frames are built whenever lexscan encounters a macro.
     159$    expand returns the next word of macro text if we are processing
     160$    macros and calls trulex otherwise.
     161
     162$    when expand discovers a user-argument in the text of a macro
     163$    it begins substituting the actual argument. this is done by
     164$    building an extra stack frame which contains:
     165$
     166$    first word:    points to next word of argument text in astack
     167$    second word:   indicates zero arguments.
     168$
     169$    the pointer to astack is biased by the dimension of mtab to
     170$    distinguish an argument stack frame from a macro stack frame.
     171
     172$ the parser does not communicate with the scanner directly, but
     173$ instead calls an interface routine -gettok-.  this routine
     174$ manipulates a token buffer which is used to implement backtracking
     175$ in the parser.
     176
     177
     178$ outputs of the parser
     179$ ---------------------
     180
     181$ the parser produces two tables:
     182
     183$ 1. the polish string
     184
     185$    the polish string is represented as an array whose entries
     186$    have two fields:
     187
     188$    pol_typ:      type code pol_xxx
     189$    pol_val:      value of entry
     190
     191$    entries in the polish string are refered to as 'nodes'. there
     192$    are three types of nodes:
     193
     194$    a. names
     195
     196$       these nodes indicate names appearing in the source program.
     197$       they have:
     198
     199$       pol_typ:     pol_name
     200$       pol_val:     pointer to 'names' array
     201
     202$       the names array is used to store the actual name of
     203$       the node.
     204
     205$    b. counters
     206
     207$       counters are integers which indicate the number of clauses
     208$       found by each  operation of the parser. they have:
     209
     210$       pol_typ:     pol_count
     211$       pol_val:     integer indicating count
     212
     213$    c. markers
     214
     215$       markers are nodes indicating points where semantic routines
     216$       are to be invoked. they have:
     217
     218$       pol_typ:     pol_mark
     219$       pol_val:     code p_xxx
     220
     221$    the polish string is written out whenever it is full. rather
     222$    than write out both the polish string and the names array,
     223$    out, we write the names entry for each node directly after
     224$    the node itself.
     225
     226$    the variable 'polp' points to the last entry in the string.
     227
     228$    the polish string is actually written onto two files known
     229$    as the main file and the auxiliary file. the two files
     230$    are merged by the semaintic pass. this allows the semanitc
     231$    pass to act as if there were no forward references to
     232$    procedures.
     233
     234
     235$ 2. names
     236
     237$    names is a word-sized array used to store the names of tokens.
     238$    we pack each token into names by converting it to a 'standard'
     239$    self defining string, then putting each word of the string into
     240$    a successive word of names, starting with the low order word.
     241
     242$    pointers to names always point to the low order word of a string,
     243$    and thus allow us to access its slen and sorg fields.
     244
     245$    names entries are 'standardized' in the sense that an
     246$    n-character token will always have an sorg of .sds. n +1.
     247
     248
     249
     250
     251
     252$ the symbol table
     253$ ----------------
     254
     255$  the parser uses a symbol called symtab. it has the following
     256$  fields:
     257
     258
     259$   name:        pointer to names array
     260$   lex_typ:     extended lexical type
     261$   key_val:     lexical value, see below
     262$   lit_val:     literal value, see below.
     263$   link:        clash list link
     264$   morg:        points to first word of macro text.
     265$   margs:       number of macro arguments
     266$   mcode:       indicates representation in macro text
     267
     268$  in the code which follows we distinguish between 'keywords' and
     269$  'literals'.
     270
     271$  a 'keyword' is any token whose lex_typ is not some standard
     272$  type such as name, integer, or real. there are several groups
     273$  of keywords, such as binary operators, statement keywords, etc.
     274$  each set of keywords forms a separate lexical class.
     275
     276$  each keyword has a value associated with it. this value is
     277$  given by the symbols key_val field. its meaning is a function
     278$  of its lex_typ:
     279
     280$             lex_typ               key_val
     281$             --------               -------
     282
     283$             l_dkey                 index for branch on keyword
     284$             l_tkey1                as above
     285$             l_tkey2                as above
     286$             l_stkey                as above
     287$             l_lparen                 as above
     288$             l_bin                  precedence
     289$             l_un                   precedence
     290$             l_minus                precedence
     291$             l_debug                debugging code dbg_xxx
     292
     293$      key_val is zero for all other types.
     294
     295$  a 'literal' is any token which appears explicitly in the
     296$  grammar. the lit_val field of each literal contains a code
     297$  lit_xxx which identifies which literal it is. tokens which
     298$  are not literals have a lit_val of 0.
     299
     300$  note that key_val and lit_val must be disjoint, since certain
     301$  tokens are both literals and keywords.
     302
     303$  symtab is arranged as a hash table, with the link field used
     304$  to chain entries with the same hash code. a separate table
     305$  called 'heads' is used to hold the heads of clash chains, and
     306$  the variable 'symtabp' points to the last used symtab entry.
     307
     308$   note that tokens are hashed on their names only, not on their types.
     309$   the types of keywords are set by the initialization routine. if
     310$   trulex discovers a token whose lex_typ field is not already set,
     311$   it fills in a default.
     312
     313
       1 .=member mods
       2
       3
       4$ program revision history
       5$ ------------------------
       6
       7$ this section contains a description of each revision to the program.
       8$ these descriptions have the following format:
       9$
      10$ mm-dd-yy      jdate     author(s)
      11$
      12$ 1.............15........25........................................
      13$
      14$ where mm-dd-yy are the month, day, and year, and jdate is the julian
      15$ date.
      16$
      17$ each time a revision is installed, the author should insert a
      18$ description after line 'mods.21', and change the macro 'prog_level'
      19$ to the current julian date.
      20$
      21$ ......................................................................
sunb   1
sunb   2
sunb   3$ 07/24/84     84206     s. freudenberger
sunb   4$
sunb   5$  1. introduce program parameters -lcp- and -lcs- to control default
sunb   6$     output:  -lcp- controls the listing of program parameters, i.e.
sunb   7$     the initial phase heading;  -lcs- controls the listing of the
sunb   8$     final statistics.  if both are set, the old listing is generated;
sunb   9$     if neither is set, no output is generated unless an error occurs.
sunb  10$     modules affected: start, prsini, and prstrm.
asca   1
asca   2
asca   3$ 03/05/84     84065     d. shields
asca   4$
asca   5$  1. for s37, add option 'cset=asc' to permit translation of programs
asca   6$     developed in ascii without need to translated to portable
asca   7$     character set.
asca   8$     modules affected: start, prsini, and initlex.
suna   1
suna   2
suna   3$ 02/05/84     84065     s. freudenberger
suna   4$
suna   5$  1. support motorola mc68000 microprocessor on sun workstation.
suna   6$     modules affected: start, prsini, ptinit, trulex, initlex,
suna   7$                       stackexp, and svtab.
smfc   1
smfc   2
smfc   3$ 09/01/83     83244     s. freudenberger
smfc   4$
smfc   5$  1. document machine-dependency of integer representation in setl
smfc   6$     binary i/o.
smfd   1$     module affected:  newstat.
smfc   7$  2. correct a comditional assembly directive for s10/s20.
smfc   8$     module affected:  trulex.
smfb   1
smfb   2
smfb   3$ 08/08/83     83220     s. freudenberger
smfb   4$
smfb   5$  1. increase the dimension of astack and mstack to 1023.
smfb   6$     module affected:  start.
smfb   7$  2. check while collecting open tokens for the end of a loop header,
smfb   8$     to avoid scanning beyond it.  this required to add the keyword end
smfb   9$     to the list of keywords defined by default.
smfb  10$     modules affected: start, initstd, opentoks, endtoks, and chktoks.
smfb  11$  3. code anyc string search function inline.
smfb  12$     modules affected: trulex and initlex.
smfb  13$  4. change some cases of s32, s37, s47 conditional assembly to r32.
smfb  14$     modules affected: inparse and svtab.
smfa   1
smfa   2
smfa   3$ 12/16/82     82350     s. freudenberger
smfa   4$
smfa   5$  1. modify trulex to call an internal rather than an external
smfa   6$     subroutine to read the next character.
smfa   7$     module affected:  trulex.
smfa   8$     module deleted:   getc.
smfa   9$  2. check that there really exists an open loop when we encounter a
smfa  10$     'continue' or 'quit' statement with no tokens.
smfa  11$     module affected:  chktoks and ermsg.
      22
      23
      24$ 08/12/82     82224     s. freudenberger
      25$
      26$  1. we postpone the check for constant expressions to the semantic
      27$     pass, and are thus able to constant fold additional operators.
      28$     module affected:  remote text inclusion.
      29$  2. the token buffer for the current token is set to zero before we
      30$     attempt to find the token.
      31$     module affected:  gettok.
      32$  3. we check the symbol table index for zero before we retrieve the
      33$     token name.
      34$     mocudule affected:  symsds.
      35$  4. the enders for error recovery in expressions have been expanded
      36$     to include 'elseif' and 'else', and have been corrected to use
      37$     portable character set representations in the initialisation code.
      38$     module affected:  ermet.
      39$  5. we check that the token buffer indeces are defined (non-zero),
      40$     and replace the names of invalid tokens between tok_out and
      41$     tok_in by question marks.
      42$     module affected:  trcbak.
      43
      44
      45$ 06/15/82     82166     s. freudenberger
      46$
      47$  1. the setl source map file has been renamed to ssm from src.  it is
      48$     now written out whenever the ssm program parameter is supplied,
      49$     not as a funtion of the opt program parameter.  the opt program
      50$     parameter now merely checks the availability of the setl q1 inter-
      51$     face and that an ssm file has been specified.
      52$     modules affected: start, prsini, putcard, stat1, newstat, and
      53$                       prstrm.
      54$  2. trailink blanks are removed before the record is written to the
      55$     ssm file.
      56$     modules affected: trulex and putcard.
      57$  3. we count the 'case  of' of a case statement as a separate
      58$     statement.
      59$     module affected:  (remote text inclusion)
      60
      61
      62$ 06/01/82     82152     s. freudenberger
      63$
      64$  1. we added conditional code for the s37 mts implementation.
      65$     module affected:  prsini.
      66$  2. we re-introduced the keyword 'map' for ambiguous maps, i.e. maps
      67$     which can have both single- and multi-valued image points.
      68$     module affected:  initkey.
      69$  3. the globals 'stat_no' and 'cstat_no' have been deleted.  they were
      70$     dead since 82032.2.
      71$     modules affected: start, stat1, and newstat.
      72$  4. a new global flag has been introduced:  'eor_flag' is set whenever
      73$     a new input record is read.
      74$     modules affected: start and getc.
      75$  5. the implicit string concatenation now actually requires an end-of-
      76$     record between the two string operands.
      77$     module affected:  trulex.
      78
      79
      80$ 03/16/82     82075     s. freudenberger
      81$
      82$   1. the 'rtrs0' and 'rtrs1' debugging options have been deleted from
      83$      the initialisation code of the symbol table.
      84$      module affected:  initkey.
      85
      86
      87$ 02/01/82     82032     s. freudenberger
      88$
      89$  1. the listing output has been moved to start each line in column 1
      90$     rather than column 7.  dump outputs have not been modified.
      91$     modules affected: prsini, usratp, overfl, and prstrm.
      92$  2. the statement counters have been modified to correspond to the
      93$     variables used in the remaining compile phases, i.e. the use of
      94$     cstmt_count, etc.
      95$     modules affected: start, parse, putcard, stat1, and newstat.
      96$  3. the setl optimiser needs the setl binary interface to communicate
      97$     with other compiler phases.  thus we can check already here
      98$     whether we will run into problems later.  furthermore, the
      99$     optimiser likes to produce an annotated source listing:  we
     100$     generate here a map from cummulative statement numbers to tuples
     101$     of source lines, in setl binary format, and write it to the file
     102$     src.
     103$     new program parameters:
     104$             opt=0/1         global optimisation flag:  if set, write
     105$                             setl binary map from cummulative statement
     106$                             numbers to tuples of source lines
     107$             src=/           file to which the setl binary map is
     108$                             written
     109$     new inclusion from compl:  module binio.
     110$     modules affected: start, prsini, getcard, putcard, stat1, newstat,
     111$                       and prstrm.
     112$     module deleted:   lstcrd.
     113$  4. several tokens have been predefined, which before were defined
     114$     when needed:  ':=', 'then', and 'end'.
     115$     modules affected: start, initstd, chkrepr, and badasn.
     116$  5. we only check tokens up to the 'then' in an 'if' statement.  this
     117$     prevents look-ahead beyond the 'then', and thus keeps statement
     118$     numbers correct for the source listing.
     119$     modules affected: opentoks, endtoks, and checktoks.
     120
     121
     122$ 02/01/82    82032     d. shields
     123$
     124$ use r32 conditional symbol for standard 32-bit fields.
     125$ this replaces the field definitions for s32, s37 and s47.
     126
     127
     128$ 01/15/82     82015     s. freudenberger & d. shields
     129$
     130$  1. prsini has been modified to print the phase header to the terminal
     131$     whenever the new control card parameter 'termh=0/1' is set.
     132$     new control card parameter:
     133$         termh=0/1           print phase header on the terminal file
     134$     module affected:  prsini.
     135$  2. the nameset nsptab has been put in start to simplify compilation
     136$     for s32u and s47 (unix).
     137
     138
     139$ 11/29/81    81333     d.shields
     140$
     141$  1. support s47: amdahl uts (universal timesharing system).
     142$     this implementation runs on s37 architecture using an operating
     143$     system very close to unix (v7), and uses the ascii character set.
     144
     145
     146$ 08/13/81     81232     s. tihor
     147$
     148$  1.  expand the size of the s32 name table for the ada compiler.
     149$  2.  expand the heads, symtab, and polish file sizes accordingly.
     150$  3.  add the /upd switch and the /seq switch.  the /seq switch
     151$      initially supports the four options: l(line numbers),
     152$      s(stmt_num), ls(both) and nothing.
     153$  4.  add support for s20 (s10 with extended addressing).
     154
     155
     156$ 12/05/80     80340     s. tihor & d. shields
     157$
     158$  1. shields mods for unix checkout
     159$  1a. support lower case for unix
     160$  1b. use binary parse tables for unix checkout
     161$  2. use name$sio to capture the names of the stdin, stdout, and stderr
     162$     (term) files.
     163$  3. correct two stropped key words in ermet to unstropped form.
     164$  4. do not convert percent to colon inside of quotes even on s66.
     165
     166
     167$ 11/05/80     80310     s. freudenberger
     168$
     169$ the puterr routine has been split, so that the unexpected-end-of-file
     170$ error message is printed more reasonably.
     171
     172
     173$ 08/01/80     80214     s. freudenberger
     174$
     175$  1. for implementations selecting the .+lc conditional assembly, the
     176$     test in the getcard routine for blank after .title has been
     177$     changed to a search for blank-equivalent separators.
     178
     179
     180$ 06/20/80     80172      e. deak
     181$
     182$ modifications have been made to improve the error recovery.  most
     183$ changes have been made in the ermet routine to prevent scanning
     184$ over reserved words.
     185
     186
     187$ 07/08/80     80190     s. freudenberger
     188$
     189$  1. a special polish node is written to mark the end of both the
     190$     polish and the auxiliary polish files.
     191$  2. the line "no errors..." is not echoed to the terminal anymore.
     192$  3. the layout of the title line has been changed.
     193$  4. lines containing listing directives are counted as input lines.
     194
     195
     196$ 05/27/80     80148     s. freudenberger
     197$
     198$  1. adjust various macros for s37 in preparation to compile and
     199$     run the optimizer on that system.
     200
     201
     202$ 04/11/80     80102     d. shields
     203$
     204$ 1. delete is_primitive.
     205$ 2. 'rgcd1' was wrongly spelled 'tgcd1'.
     206
     207
     208$ 02/04/80     80035     s. freudenberger and d. shields
     209$
     210$ 1. implement unary operators acos, asin, atan, char, cos, exp,
     211$    log, sin, sqrt, tan and tanh.
     212$ 2. implement binary operators atan2 and interrogation (?).
     213$ 3. implement type predicates is_atom, is_boolean, is_integer,
     214$    is_map, is_real, is_set, is_string and is_tuple.
     215$    change prim to is_primitive.
     216$ 4. add procedure host() to provide means for adding
     217$    implementation- or site-dependent features.
     218$ 5. drop cset_dis option.
     219$ 6. correct the call to 'opninc' so that the '.copy' option must
     220$    start in column 2.
     221$ 7. the meta-macros and system parameter macros have been replaced
     222$    by an inclusion of cmnpl.sysmac.
     223$ 8. the recursion stack of the parser has been changed to account
     224$    for the possibility of more than 255 <*cl>'s.  this change was
     225$    a consequence of the increase in vlen_lim (cmnpl.q1symtab).
     226
     227
     228$ 01/16/80     80016     s. freudenberger
     229$
     230$ change 79248.5 has been undone, since the code generator symbol table
     231$ allocator does not handle this extension properly.
     232
     233
     234$ 01/15/80     80015     s. freudenberger
     235$
     236$ 1. correct 'puttab' and 'putxtab' for backtracked environment.
     237$ 2. correct 'retab'/'puttabs' so that subr-statement follows '*deck'.
     238$ 3. correct error message in correspondence to grammar change.
     239
     240
     241$ 12/17/79     79351     s. freudenberger
     242$
     243$ 1. 'puttabs' has been shortened to six characters: 'puttbs'.
     244
     245
     246$ 11/30/79     79334     s. freudenberger
     247$
     248$ 1. the names table has been increased to the same size as in cmnpl.
     249$ 2. on polish atbel overflow, we only write out hte non-backtracked
     250$    part of the polish.
     251
     252
     253$ 11/12/79      79316     s. freudenberger
     254$
     255$ 1. the mode keyword 'map' has been dropped.  the initialization
     256$    for the repr keywords has been updated accordingly.
     257$ 2. the error message for slash after compound operator has
     258$    been included.
     259$ 3. new error messages have been added according to the grammar
     260$    extensions.
     261
     262
     263$ 09/17/79     79259     s. freudenberger
     264$
     265$ 1. the current input line is printed unconditionally when an error
     266$    is found.
     267$ 2. the grammar action to force the printing of the current line does
     268$    not call 'put_card' directly anymore, but rather the newly added
     269$    routine 'lstcrd', which checks whether the 'list' option has been
     270$    selected.
     271
     272
     273$ 09/13/79     79256     s. freudenberger
     274$
     275$ 1. logical file names are sized using 'filenamlen' (define in
     276$    cmnpl.sysmac, duplicated in prspl.start since sysmac is not
     277$    included here.
     278
     279
     280$ 09/05/79     79248     s. freudenberger
     281$
     282$
     283$ this correction set installs setl 2.1
     284$
     285$
     286$  1. a conditional assembly 'lc' has been added to control upper/lower
     287$     case equivalency for identifiers.
     288$  2. a character set control card parameter ('cset') has been added to
     289$     control selection of either the portable or the extended character
     290$     sets. (for further details, see comment in member start)
     291$  3. the lexical classes have been changed and ammended.
     292$  4. the parser debugging options have been renamed and made part of
     293$     the general 'debug' statement.
     294$  5. we now accept certain lexical classes as names.  these are the
     295$     base type and the mode keywords, as well as the options for
     296$     the 'debug' and 'trace' statements.
     297$  6. 'trulex' and 'initlex' have been completely rewritten, using the
     298$     little string primitives.  the modification also reflects the
     299$     upper/lower case folding for identifiers.
     300$  7. 'trulex' now accepts '.5' as a real denotation.
     301$  8. 'initlex' contains the code to define one-character alternatives
     302$     for predefined tokens.
     303$  9. the error handler has been updated.
     304$ 10. the routines 'getc' and 'altchar' have been added.  'getc'
     305$     returns the next character from the input buffer, and 'altchar'
     306$     defines its second argument as an alternative for its first
     307$     argument.
     308
     309
     310$ 07/20/79     79201     s. freudenberger
     311$
     312$ 1. error messages on the s10 are echoed to the device tty:, and not
     313$    the file 'tty'.
     314$ 2. the default for the s32 has been changed so that, in the absence
     315$    of a 'term' parameter, errors are echoed to 'sys$error'.
     316$ 3. error messages on the s10 are preceded by '?', the standard error
     317$    marker for the dec-10.
     318
     319
     320$ 05/18/79     79138     s. freudenberger
     321
     322$ 1. the quick parser has been renamed from stlqprs to stlqrs.
     323$ 2. the term option has been cleaned up so that the skip's and
     324$    the call's to contlpr interleave correctly.
     325$ 3. a number of extreneous return statements have been deleted.
     326$ 4. the source has been resequenced.
     327
     328
     329$ 04/27/79     79117     s. freudenberger
     330
     331$ the environment has been modified to provide an assembly-level
     332$ module which contains the parse table output from syn.  this
     333$ module is used, and it is not necessary anymore to read 'synbin'
     334$ for each run.
     335
     336
     337$ 04/12/79     79102     s. freudenberger and d. shields
     338
     339$ 1. three character set changes have been implemented:
     340$     1. the ascii number sign is not a synonym for the keyword exist.
     341$       it is currently unused.
     342$     2. the ascii circumflex is not used as the break character.
     343$        it is currently unused.
     344$     3. the ascii underline is the new break character.
     345$        it is not acceptable as a synonym for the keyword in.
     346$ 2. initial modifications have been included to eliminatethe need
     347$    to read in the grammar file for every run.
     348
     349
     350$ 04/10/79     79100     s. freudenberger
     351
     352$ 1. the parse listing commands -.eject- and -.title- only eject a
     353$    page when the source is listed.
     354$ 2. since there was no precedenc 7, all precedence 8 operators have
     355$    been given precedence 7.  the operators +:= and -:= have been
     356$    given precedence 8.
     357
     358
     359$ 04/03/79     79093     s. freudenberger and d. shields
     360
     361$ 1. as a first step to remove prefix stropping, the pre-control-
     362$    card parameter has been removed, and the pre_flag initialized
     363$    to false, i.e. reserved word stropping.
     364$ 2. a conditional symbol -qp- has been added, allowing the creation
     365$    of a smaller version of the parser.  the main differences between
     366$    the regular parser and the -quick- parser are the following:
     367$    a. reduced macro- and symbol tables
     368$    b. no polish strings are written onto the files -pol-/-xpol-
     369$    c. there are no dump routines in this version.
     370$ 3. a terminal option has been added, echo-printing all error
     371$    messages onto the file specified by the term control card
     372$    parameter.
     373
     374
     375$ 03/27/79     79086     s. freudenberger
     376
     377$ 1. two tests were corrected in -endtoks- and -checktoks-,
     378$    so that the correct number of tokens will be checked.
     379$ 2. if dumps are requested, the dump routines will be invoked
     380$    from -puttabs- rather than from -puttab- and -putxtab-.
     381$ 3. two namesets have been renamed to avoid external name
     382$    conflicts on systems which do not distinct between data
     383$    and program segments:
     384$         initkeyns ---> nsinitkey
     385$         trulexns  ---> nstrulex
     386
     387
     388$ 03/05/79     79065     s. freudenberger
     389
     390$ 1. the size of the macro table (mtab) has been increased.
     391$ 2. subroutine -init- has been renamed to -prsini-.  this is both
     392$    more consistent with the remaining phases of the compiler, and
     393$    avoids a name conflict in the s10 implementation.
     394$ 3. ltlsyn has been changed to emit a member synmax.  this member
     395$    contains a macro -parselitmax- giving the total number of
     396$    literals in the grammar.  -initlit- has been modified accordingly.
     397$ 4. the error handling and recovery has been changed considerably.
     398$    4.1 a new control card parameter has been added: etoks=5/5
     399$        in the new version, each error message prints the last
     400$        etoks tokens that have been accepted by the parser, plus
     401$        the tokens examined but not accepted.  the latter are
     402$        underlined, using a minus sign for unreserved and an
     403$        equal sign for reserved tokens.
     404$    4.2 if the parser finishes to parse a program but is not at
     405$        the end of the input file, it assumes that some error must
     406$        have derailed it, and resumes parsing with the production
     407$        
     408$    4.3 if the tokens after -end- do not match, a check is performed
     409$        to see whether one ore more -end-s are missing.  if so, an
     410$        error is flaged, but the parse proceeds, inserting the missing
     411$        -end-(s).
     412$ 5. the statement numbering has been corrected (finally !).  the
     413$    cause for the neurotic behaviour was the routine -opentoks-,
     414$    which save a fixed number of tokens.  it has been modified so
     415$    that it will only save the tokens to the minimum of the pre-
     416$    defined limit and the next semicolon.  this change is justified
     417$    since both -endtoks- and -checktoks- only compare to the next
     418$    semicolon.
     419
     420
     421$ 12-27-78     78361     a. grand and d. shields
     422
     423$ this correction set installs machine-dependent code for the
     424$ ibm 370, dec-10, and vax.
     425
     426
     427$ 12-8-78     78342     a. grand
     428
     429$ 1. the scanner did not allow a signed exponent in real constants.
     430$ 2. there was a grammar bug which required two new error messages.
     431
     432
     433$ 11-15-78     78319     a. grand and s. freudenberger
     434
     435$ this correction does nothing but install the deck'mods'
     436
       1 .=member start
       2 .=include cndasm
suna   8
       3 .-qp.
       4 .+s66    subr start;
       5 .+r32    prog stlprs;
suna   9 .+r36    prog stlprs;
suna  10 .+qp.
suna  11          prog stlprs;
       8 ..qp
       9
      11
      12$ this is the main routine of the scanner-parser. it contains
      13$ all the global variable declarations, plus calls to invoke
      14$ the rest of the program.
      15
      16
      17      +* prog_level =    $ program level(julian date of last fix)
sunb  11          'prs(84206) '
      19          **
      20
      21 $    conditional symbols
      22
      23 $    enable qp to compile quick parse which has reduced
      24 $    table sizes and runs as stand-along program to assist
      25 $    in finding syntactic errors quickly.
      26
      27$ enable defenv_ptinit if procedure ptinit defined by environment
      28
      29 .+set defenv_ptinit
      30
      31 .+s47.
      32 .-set defenv_ptinit  $ read in parse tables during checkout.
      33 ..s47
      34
      35
      36 .=include sysmac
      37
      38$ character constants
      39
      40      +* cc_tab  =            $ tab character (if available) or blank
      41 .+s10    09
      42 .+s20    09
      43 .+s32    09
      44 .+s47    09
      45 .+s37    1r
      46 .+s66    1r
suna  13 .+s68    09
      47          **
      48
      49
      50
      51
      52      nameset symtab;    $ symbol table and related variables
      53
      54          +*  symtab_sz  =  $ size of symtab
      55 .+s66        120
      56 .+r32        168
      57 .+s10        108
      58 .+s20        108
      59          **
      60          +*  symtab_lim  =  2000  **  $ dimension of symtab
      61 .+qp     +*  symtab_lim  =  1000  **  $ (small) dimension of symtab
      62
      63          size symtab(symtab_sz);
      64          dims symtab(symtab_lim);
      65
      66          size symtabp(ps);   $ pointer to last symtab entry
      67          data symtabp = 0;
      68
      69 .+s66.
      70          +*  name(i)          =  .f. 001, 16, symtab(i)  **
      71          +*  lex_typ(i)       =  .f. 017, 08, symtab(i)  **
      72          +*  key_val(i)       =  .f. 025, 08, symtab(i)  **
      73          +*  lit_val(i)       =  .f. 033, 08, symtab(i)  **
      74          +*  link(i)          =  .f. 065, 16, symtab(i)  **
      75          +*  morg(i)          =  .f. 081, 16, symtab(i)  **
      76          +*  mcode(i)         =  .f. 097, 16, symtab(i)  **
      77          +*  margs(i)         =  .f. 113, 08, symtab(i)  **
      78 ..s66
      79
      80 .+r32.
      81          +*  name(i)          =  .f. 001, 32, symtab(i)   **
      82          +*  lex_typ(i)       =  .f. 033, 08, symtab(i)   **
      83          +*  key_val(i)       =  .f. 041, 08, symtab(i)   **
      84          +*  lit_val(i)       =  .f. 049, 08, symtab(i)   **
      85          +*  link(i)          =  .f. 065, 32, symtab(i)   **
      86          +*  morg(i)          =  .f. 097, 32, symtab(i)   **
      87          +*  mcode(i)         =  .f. 129, 32, symtab(i)   **
      88          +*  margs(i)         =  .f. 161, 08, symtab(i)   **
      89 ..r32
      90
      91 .+s10.
      92          +*  name(i)          =  .f. 001, 18, symtab(i)  **
      93          +*  lex_typ(i)       =  .f. 019, 08, symtab(i)  **
      94          +*  key_val(i)       =  .f. 027, 08, symtab(i)  **
      95          +*  lit_val(i)       =  .f. 037, 08, symtab(i)  **
      96          +*  link(i)          =  .f. 055, 18, symtab(i)  **
      97          +*  morg(i)          =  .f. 073, 18, symtab(i)  **
      98          +*  mcode(i)         =  .f. 091, 18, symtab(i)  **
      99          +*  margs(i)         =  .f. 045, 08, symtab(i)  **
     100 ..s10
     101
     102 .+s20.
     103          +*  name(i)          =  .f. 001, 18, symtab(i)  **
     104          +*  lex_typ(i)       =  .f. 019, 08, symtab(i)  **
     105          +*  key_val(i)       =  .f. 027, 08, symtab(i)  **
     106          +*  lit_val(i)       =  .f. 037, 08, symtab(i)  **
     107          +*  link(i)          =  .f. 055, 18, symtab(i)  **
     108          +*  morg(i)          =  .f. 073, 18, symtab(i)  **
     109          +*  mcode(i)         =  .f. 091, 18, symtab(i)  **
     110          +*  margs(i)         =  .f. 045, 08, symtab(i)  **
     111 ..s20
     112
     113
     114$ the array 'heads' is used to hold the head of each clash list.
     115$ its dimension must be a prime.
     116
     117          +*  heads_lim  =  509  **
     118
     119          size heads(ps);
     120          dims heads(heads_lim);
     121          data heads = 0(heads_lim);
     122
     123$ constants for lexical types
     124$ ---------------------------
     125
     126 .=zzyorg z
     127
     128      defc(l_name)            $ names
     129      defc(l_bold)            $ bold (operator) name
     130      defc(l_int)             $ integer denotation
     131      defc(l_real)            $ real denotation
     132      defc(l_string)          $ string denotation
     133      defc(l_delim)           $ delimiters
     134      defc(l_dkey)            $ declaration statement keyword
     135      defc(l_modekey)         $ system defined modes
     136      defc(l_btkey)           $ base types (local, remote, ...)
     137      defc(l_stkey)           $ statement keyword
     138      defc(l_rwkey)           $ read/write keywords
     139      defc(l_rkey1)           $ libraries, reads, writes
     140      defc(l_rkey2)           $ imports, exports
     141      defc(l_bin)             $ system defined binary operators
     142      defc(l_from)            $ from, etc.
     143      defc(l_un)              $ system defined unary operators
     144      defc(l_unbin)           $ system defined unary/binary operators
     145      defc(l_dots)            $ two or more dots
     146      defc(l_debug)           $ compiler debugging options
     147      defc(l_trace)           $ user debugging options
     148
     149      +*  l_min  =  l_name    **
     150      +*  l_max  =  l_trace   **
     151
     152$ standard symbols
     153$ ----------------
     154
     155$ the first few symbol table entries are used for standard literals
     156$ such as '.macro', '.endm', etc. these locations are identified by
     157$ a series of macros sym_xxx.
     158
     159 .=zzyorg z
     160
     161          defc(sym_macro)     $ keyword macro
     162          defc(sym_endm)      $ keyword endm
     163          defc(sym_drop)      $ keyword drop
     164          defc(sym_semi)      $ semicolon
     165          defc(sym_comma)     $ comma
     166          defc(sym_lp)        $ left parenthesis
     167          defc(sym_rp)        $ right parenthesis
     168          defc(sym_asn)       $ assignment operator
     169          defc(sym_then)      $ keyword then
     170          defc(sym_end)       $ keyword end
smfb  16          defc(sym_do)        $ keyword do
     171
     172      end nameset;
     173
     174
     175      nameset names;   $ names
     176                       $ -----
     177
     178      +* names_lim  =         $ dimension of names
     179 .+s10    1500
     180 .+s20    1500
     181 .+r32   65536
     182 .+s66    1024
     183          **
     184
     185          size names(ws);
     186          dims names(names_lim);
     187
     188          size namesp(ps);  $ pointer to last names entry
     189          data namesp = 0;
     190
     191$ the following fields access the slen and sorg fields of names
     192$ entries:
     193
     194          +*  n_slen(p)         =  slen names(p)                  **
     195          +*  n_sorg(p)         =  sorg names(p + (.sl.+1) / ws)  **
     196
     197      end nameset;
     198
     199
     200
     201      nameset polish;       $ declarations for polish string
     202                            $ ------------------------------
     203
     204          +*  polsz     =    16  **  $ size of polish
     205 .+r32    +*  polsz     =    32  **  $ size of pol must be 2+log2(name_
     206          +*  pol_lim   =  3000  **  $ dimension of polish string
     207 .+qp     +*  pol_lim   =    10  **  $ dimension of (small) polish array
     208          +*  xpol_lim  =  1000  **  $ dimension of auxiliary string
     209 .+qp     +*  xpol_lim  =    10  **  $ dimension of (small) xpolish arra
     210
     211          size polish(polsz);
     212          dims polish(pol_lim);
     213
     214          size polp(ps);   $ pointer to last entry
     215          data polp = 0;
     216
     217          +*  pol_typ(i)     =  .f. 01, 02, polish(i)  **
     218          +*  pol_val(i)     =  .f. 03, 14, polish(i)  **
     219 .+r32    +*  pol_val(i)     =  .f. 03, 30, polish(i)  **
     220
     221
     222$ auxiliary polish string
     223          size xpolish(polsz);
     224          dims xpolish(xpol_lim);
     225
     226          size xpolp(ps);   $ pointer to last entry
     227          data xpolp = 0;
     228
     229          +*  xpol_typ(i)     =  .f. 01, 02, xpolish(i)  **
     230          +*  xpol_val(i)     =  .f. 03, 14, xpolish(i)  **
     231 .+r32    +*  xpol_val(i)     =  .f. 03, 30, xpolish(i)  **
     232$ polish string types
     233
     234 .=zzyorg z
     235
     236          defc0(pol_name)     $ name
     237          defc0(pol_count)    $ counter
     238          defc0(pol_mark)     $ marker
     239          defc0(pol_end)      $ end-of-file marker
     240
     241          +*  pol_min  =  pol_name   ** $ minimum type
     242          +*  pol_max  =  pol_end    ** $ maximum type
     243
     244$ the macro definitions for the marker codes p_xxx are produced
     245$ by syn.
     246
     247          +*  synimpmap(a, b)  =  macdef(a = b)  **
     248
     249 .=include synmac
     250 .=include synimp
     251
     252
     253$ utilities to read and write polish
     254
     255          +*  putp(val, tp)  =  $ write node onto polish
     256 .-qp         if (polp = pol_lim) call puttab;
     257              polp = polp + 1;
     258 .-qp         pol_typ(polp) = tp;
     259 .-qp         pol_val(polp) = val;
     260              **
     261
     262
     263          +*  putxp(val, tp)  =  $ write node onto xpolish
     264 .-qp         if (xpolp = xpol_lim) call putxtab;
     265              xpolp = xpolp + 1;
     266 .-qp         xpol_typ(xpolp) = tp;
     267 .-qp         xpol_val(xpolp) = val;
     268              **
     269
     270
     271      end nameset polish;
     272
     273
     274      nameset macro;    $ declarations for macro processor
     275                        $ --------------------------------
     276
     277          +*  mtab_lim  =  3000  **  $ dimension of mtab
     278 .+qp     +*  mtab_lim  =   800  **  $ (small) dimension of mtab
     279
     280          size mtab(ps);
     281          dims mtab(mtab_lim);
     282
     283          size mtabp(ps);    $ pointer to last entry in mtab
     284          data mtabp = 0;
     285
smfb  17          +*  mstack_lim  =  1023  **  $ dimension of mstack
     287
     288          size mstack(ps);
     289          dims mstack(mstack_lim);
     290
     291          size mstackp(ps);   $ pointer to last mstack entry
     292          data mstackp = 0;
     293
smfb  18          +*  astack_lim  =  1023  **  $ dimension of astack
     295
     296          size astack(ps);
     297          dims astack(astack_lim);
     298
     299          size astackp(ps);   $ pointer to last entry
     300          data astackp = 0;
     301
     302          +*  param_lim =  26  **  $ maximum no. of formal parameters
     303
     304          size params(ps);  $ array of formal parameters
     305          dims params(param_lim);
     306
     307          size paramsp(ps);  $ pointer to last parameter
     308          data paramsp = 1;
     309
     310          size expand_buff(ps);  $ 1 word buffer used by 'expand'
     311          data expand_buff = 0;
     312
     313
     314    $ biases for macro text encoding
     315
     316          +*  bias_user  =  (symtab_lim + 1)  ** $ user arguments
     317          +*  bias_gen1  =  (bias_user + 100) ** $ first use of gen arg
     318          +*  bias_gen2  =  (bias_gen1 + 100) ** $ next use of gen arg
     319
     320      end nameset;
     321
     322
     323      nameset params;   $ control card parameters
     324
     325          size upd_flag(1);   $ update format source file
sunb  12          size lcp_flag(1);   $ listing control:  program parameters
sunb  13          size lcs_flag(1);   $ listing control:  program statistics
     326          size list_flag(1);  $ print source listing
     327          size at_flag(1);    $ produce titles automatically
     328          size mlen_lim(ps);  $ macro length limit
     329          size pel(ps);       $ parse error limit
     330          size etok_lim(ps);  $ no. of tokens printed after error msg
     331          size m_flag(1);     $ measurement flag
     332          size opt_flag(1);   $ global optimisation flag
     333          size tp_flag(1);    $ terminate after parsing
     334          size cset_str(.sds. 10);    $ source character set
     335          size seqf_str(.sds. 10);    $ sequence information format
     336          size seqf_flag(2);          $ sequence information code
     337
     338          $ options for parser debugging
     339          size et_flag(1);    $ dump tables after error
     340          size pd_flag(1);    $ dump polish
     341          size sd_flag(1);    $ dump symbol table
     342          size mt_flag(1);    $ trace macro processor
     343          size pt_flag(1);    $ trace parser
     344          size tt_flag(1);    $ trace tokens
     345
     346          size in_title(.sds. filenamlen);   $ input file
     347          size out_title(.sds. filenamlen);  $ output file
     348          size pol_title(.sds. filenamlen);  $ polish file
     349          size xpol_title(.sds. filenamlen); $ auxiliary polish file
     350          size ssm_title(.sds. filenamlen);  $ setl source map
     351          size term_title(.sds. filenamlen); $ terminal file/device
     352
     353      end nameset;
     354
     355      nameset misc;   $ miscelaneous
     356
     357          size error_count(ps);  $ number of errors
     358          data error_count = 0;
     359
     360          size line_no(ps);   $ current line number
     361          data line_no = 0;
     362
     363$ we keep three statement counters:
     364$
     365$ cstmt_count:   the cummulative statement count
     366$ ustmt_count:   the cummulative statement count at the start of the
     367$                current unit
     368$ estmt_count:   the cummulative statement count for the first code
     369$                producing instruction (currently not used in stlprs)
     370$
     371$ the current statement number equals cstmt_count - ustmt_count + 1.
     372
     373          +* stmt_count  =  (cstmt_count - ustmt_count + 1)  **
     374
     375          size cstmt_count(ps);   data cstmt_count = 0;
     376          size ustmt_count(ps);   data ustmt_count = 0;
     377          size estmt_count(ps);   data estmt_count = 0;
     378
     379          size eof_flag(1);   $ set when end of file seen
     380          data eof_flag = no;
     381
     382          size eor_flag(1);   $ set when new record is read
     383          data eor_flag = no;
     384
     385          size is_listed(1);  $ on if current line has been listed
     386          size is_written(1); $ current line has been written to src
     387          data is_listed = yes;   $ zero-th line has been listed
     388          data is_written = yes;  $ file - zero'th line has been written
     389
     390      end nameset;
     391
     392
     393$ the setl parser supports the following charcter sets, as selected
     394$ by the 'cset' control card parameter:
     395$
     396$ cset=por: the portable character set.  this set uses '<<' and '>>'
     397$           for set braces, '(/' and '/)' for tuple brackets, and
     398$           provides no single character alternates for any keyword.
     399$
     400$ cset=ext: the extended character set.  this set contains the por-
     401$           table character set as a proper subset, and specifies
     402$           an installation-dependend set of abbreviations for setl
     403$           characters and symbols, such as e.g. set braces.
     404$
     405
     406      size char_set(ps);      $ source character set
     407
     408$ character set options:
     409
     410 .=zzyorg z
     411
     412      defc(cset_por)          $ portable character set
     413      defc(cset_ext)          $ extended character set
asca   9 .+ascebc.
asca  10      defc(cset_asc)          $ for ascii text without conversion
asca  11 ..ascebc
     414
     415$ the string 'altchars' is used to store the one character
     416$ alternatives for setl symbols.  the table 'altchar_tab' maps
     417$ alternate symbols to the proper symbol table entry.
     418
     419      +*  altchar_max  =  10  **  $ maximum number of alternates
     420
     421      size altchars(.sds. altchar_max);
     422      data altchars = '' .pad. altchar_max;
     423
     424      size altchar_tab(ps);
     425      dims altchar_tab(altchar_max);
     426
     427
     428$ debugging codes
     429$ ---------------
     430
     431 .=zzyorg z
     432
     433      defc(dbg_ptrm0)         $ disable/enable macro processor trace
     434      defc(dbg_ptrm1)
     435      defc(dbg_ptrp0)         $ disable/enable parser trace
     436      defc(dbg_ptrp1)
     437      defc(dbg_ptrt0)         $ disable/enable token trace
     438      defc(dbg_ptrt1)
     439      defc(dbg_prsod)         $ open-token dump
     440      defc(dbg_prspd)         $ polish and xpolish string dumps
     441      defc(dbg_prssd)         $ symbol table dump
     442
     443      +*  dbg_min  =  dbg_ptrm0  **
     444      +*  dbg_max  =  dbg_prssd  **
     445
     446
     447      +*  prec_un    =  12  **  $ precedence for unary operators
     448      +*  prec_ubin  =  07  **  $ precedence for user defined binaries
     449
     450
     451$ file numbers
     452$ ------------
     453
     454 .=zzyorg z
     455
     456      defc(in_file)  $ input file
     457      defc(out_file)  $ output file
     458      defc(pol_file)  $ polish string file
     459      defc(xpol_file) $ auxiliary polish file
     460      defc(syn_file)  $ tables from syn
     461 .+sq1
     462$ the setl optimiser needs the setl binary interface to communicate with
     463$ other compiler phases.  thus we can check already here whether we will
     464$ run into problems later.  furthermore, the optimiser likes to  produce
     465$ an annotated source listing:  we generate here a map from  cummulative
     466$ statement numbers to tuples of source lines, in  setl  binary  format,
     467$ and write it to the file src.
     468
     469      defc(ssm_file)          $ setl source map
     470
     471 .=include binio
     472
     473      size putbhdrblk(ws);    $ binary header block
     474
     475      +* putbhdr(t, v)  =     $ write binary header block
     476          putbhdrblk         = 0;
     477          bh_typ_ putbhdrblk = t;
     478          bh_val_ putbhdrblk = v;
     479          write ssm_file, putbhdrblk;
     480          **
     481
     482      +* putbdat(v)  =        $ write one word binary data block
     483          write ssm_file, v;
     484          **
     485 ..sq1
     486
     487
     488        nameset nsptab;  $ nameset with parse table.
     489            size pt(ws);  $ interpretable code
     490            dims pt(parsearamax);
     491        end nameset nsptab;
     492
     493
     494      call prsini;
     495
     496      call parse;
     497
     498      call prstrm(no);
     499
     500 .-qp.
     501 .+s66    end subr start;
     502 .+r32    end prog stlprs;
suna  14 .+r36    end prog stlprs;
suna  15 .+qp.
suna  16          end prog stlprs;
     505 ..qp
       1 .=member prsini
       2      subr prsini;
       3
       4$ this is the main initialization routine. we begin by reading
       5$ the control card parameters and opening various files, then
       6$ call various separate routines to initialize symtab.
       7
       8
       9      size termh_flag(1);     $ print phase header on the terminal
      10
      11      size rc(ws);           $ return code from namesio
      12
      13
      14
      15      size hash(ps);          $ hashing function
      16      size timestr(.sds. 30); $ current time
      17
      18
      19      in_title = '';
      20      call namesio(in_file, rc, in_title, filenamlen); $ input file
      21      if (rc > 1) in_title = '';
      22
      23      out_title = '';
      24      call namesio(out_file, rc, out_title, filenamlen); $ output
      25      if (rc > 1) out_title = '';
      26
      27      term_title = '';
      28      call namesio(max_no_files, rc, term_title, filenamlen); $ terminal
      29      if (rc > 1) term_title = '';         $ has max file number
      30
      31
      32 .+s10.
      33      call getspp(pol_title,  'pol=pol/pol');     $ polish file
      34      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux. string
      35 ..s10
      36 .+s20.
      37      call getspp(pol_title,  'pol=pol/pol');     $ polish file
      38      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux. string
      39 ..s20
      40
      41 .+s32.
      42      call getspp(pol_title,  'pol=pol.tmp/');    $ polish file
      43      call getspp(xpol_title, 'xpol=xpol.tmp/');  $ aux. string
      44      call getspp(ssm_title,  'ssm=/ssm.tmp');    $ setl source map
      45 ..s32
      46
      47 .+s37cms.
      48      call getspp(pol_title,  'pol=pol/pol');     $ polish file
      49      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux. string
      50      call getspp(ssm_title,  'ssm=/ssm');        $ setl source map
      51 ..s37cms
      52 .+s37mts.
      53      call getspp(pol_title,  'pol=-setlpol/');   $ polish file
      54      call getspp(xpol_title, 'xpol=-setlxpol/'); $ aux. polish file
      55      call getspp(ssm_title,  'ssm=/-setlssm');   $ setl source map
      56 ..s37mts
      57 .+s47.
      58      call getspp(pol_title,  'pol=pol/pol');     $ polish file
      59      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux. string
      60      call getspp(ssm_title,  'ssm=/ssm');        $ setl source map
      61 ..s47
      62
      63 .+s66.
      64      call getspp(pol_title,  'pol=pol/pol');     $ polish file
      65      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux. string
      66 ..s66
suna  17
suna  18 .+s68.
suna  19      call getspp(pol_title,  'pol=setl.pol/');   $ polish file
suna  20      call getspp(xpol_title, 'xpol=setl.xpol/'); $ aux. polish file
suna  21      call getspp(ssm_title,  'ssm=/setl.ssm');   $ setl source map
suna  22 ..s68
      67
      68
      69      call getipp(list_flag,  'list=0/1');  $ listing control
      70      call getipp(etok_lim,   'etoks=5/5'); $ #toks printed after error
      71      call getipp(pel,        'pel=1000/1000');
      72      call getipp(mlen_lim,   'mlen=1000/1000'); $ macro length
      73      call getipp(tp_flag,    'tp=0/0');    $ terminate after parsing
      74      call getipp(pt_flag,    'pt=0/1');    $ parser trace
      75      call getipp(mt_flag,    'mt=0/1');    $ macro processor trace
      76      call getipp(et_flag,    'et=0/1');    $ error trace
      77      call getipp(tt_flag,    'tt=0/1');    $ token trace
      78      call getipp(sd_flag,    'sd=0/1');    $ symtab dump
      79      call getipp(pd_flag,    'pd=0/1');    $ polish dump
      80      call getipp(at_flag,    'at=0/1');    $ auto title
      81      call getipp(m_flag,     'meas=0/1');  $ measurements
      82      call getipp(opt_flag,   'opt=0/1');   $ global optimisation
      83      call getipp(upd_flag,   'upd=0/1');   $ upd format input
      84      call getspp(cset_str,   'cset=ext/por'); $ source character set
      85      call getspp(seqf_str,   'seq=ls/');   $ sequencing
      86      call getipp(termh_flag, 'termh=0/1'); $ print phase header
sunb  14
sunb  15
sunb  16 .-s68.
sunb  17 .-s47.
sunb  18 .-s32u.
sunb  19      call getipp(lcp_flag,   'lcp=1/1');   $ list program parameters
sunb  20      call getipp(lcs_flag,   'lcs=1/1');   $ list program statistics
sunb  21 .+s32u.
sunb  22      call getipp(lcp_flag,   'lcp=0/1');   $ list program parameters
sunb  23      call getipp(lcs_flag,   'lcs=0/1');   $ list program statistics
sunb  24 ..s32u
sunb  25 .+s47.
sunb  26      call getipp(lcp_flag,   'lcp=0/1');   $ list program parameters
sunb  27      call getipp(lcs_flag,   'lcs=0/1');   $ list program statistics
sunb  28 ..s47
sunb  29 .+s68.
sunb  30      call getipp(lcp_flag,   'lcp=0/1');   $ list program parameters
sunb  31      call getipp(lcs_flag,   'lcs=0/1');   $ list program statistics
sunb  32 ..s68
sunb  33
      87
      88      if mt_flag then $ trace macro processor
      89          monitor entry, limit = 10000;
      90      else
      91          monitor noentry;
      92      end if;
      93
      94      seqf_flag = 0;
      95      if ( 'l' .in. seqf_str) seqf_flag = 1;
      96      if ( 's' .in. seqf_str) seqf_flag = seqf_flag + 2;
      97
      98      call opninc('', 0, ' .copy ', upd_flag);  $ ltl inclusion facility
      99
     100 .+qp pol_title = '0';   xpol_title = '0'; $ set to null for quick parse
     101
     102      file pol_file    access = write,   title = pol_title;
     103      file xpol_file   access = write,   title = xpol_title;
     104 .+sq1.
     105      if slen ssm_title then
     106          file ssm_file  access = write,  title = ssm_title;
     107      end if;
     108 .-sq1.
     109      if opt_flag then
     110          put ,skip;            $ emit blank line
     111          call contlpr(27, yes);$ echo to the terminal
     112          put ,'*** setl optimiser not available ***' ,skip;
     113          call contlpr(27, no); $ stop to echo to the terminal
     114          call ltlfin(1, 0);    $ abnormally terminate
     115      end if;
     116 ..sq1
     117
     118 .+s66.
     119      rewind pol_file;   rewind xpol_file;
     120 ..s66
     121
     122      if  (.len. term_title) call opnterm(term_title);
     123
     124      if     cset_str .seq. 'por' then char_set = cset_por;
     125      elseif cset_str .seq. 'ext' then char_set = cset_ext;
asca  12 .+ascebc.
asca  13      elseif cset_str .seq. 'asc' then char_set = cset_asc;
asca  14 ..ascebc
     126      else                             char_set = cset_ext;
     127      end if;
     128
     129      $ initialize listing control
     130      call contlpr( 6, yes);  $ start paging
     131      call contlpr( 7, yes);  $ enable titling
     132      call lstime(timestr);   $ get current time
     133      call etitlr(0, 'cims.setl.' .cc. prog_level,  1, 0);
     134      call etitlr(0,                      timestr, 41, 0);
     135      call etitlr(0,                       'page', 71, 0);
     136      call contlpr( 8,  76);  $ set page number in column 76
     137      call contlpr(13,   0);  $ set number of current page
sunb  34      call contlpr(10,  rc);  $ get lines per page
sunb  35      call contlpr(15,  rc);  $ set line number within page
     138
     139
sunb  36    if lcp_flag then  $ print initial phase heading
sunb  37      put ,'parameters for this compilation: ' ,skip
     142          ,skip ,'source file: i = '              :in_title   ,a ,'. '
     143          ,skip ,'listing file: l = '             :out_title  ,a ,'. '
     144          ,skip ,'polish string file: pol = '     :pol_title  ,a ,'. '
     145          ,skip ,'auxiliary string file: xpol = ' :xpol_title ,a ,'. '
     146          ,skip ,'setl source map: ssm = '        :ssm_title  ,a ,'. '
     147          ,skip ,'list directives: list = '       :list_flag  ,i ,', '
     148                ,'at = '                          :at_flag    ,i ,'. '
     149                ,'seq = '                         :seqf_str   ,a ,'. '
     150          ,skip ,'character set: cset = '         :cset_str   ,a ,'. '
     151          ,skip ,'parse error limit: pel = '      :pel        ,i ,'. '
     152                ,'parse error file: term = '      :term_title ,a ,'. '
     153          ,skip ,'global optimisation: opt= '     :opt_flag   ,i ,'. '
     154                ,'measurements: meas = '          :m_flag     ,i ,'. '
     155          ,skip
     156          ,skip;
sunb  38    end if;
     157
     158
     159      if termh_flag then
     160          $ the following line is printed on the terminal file only
     161          call contlpr(26, no);   call contlpr(27, yes);
     162          put ,'  start cims.setl.' ,prog_level :timestr ,a ,skip;
     163          call contlpr(26, yes);  call contlpr(27, no);
     164      end if;
     165
     166
     167$ next we call three routines to initialize reserved names, keywords,
     168$ and literals. the order of these calls is important, since we assume
     169$ that some symbols will always have the same position in symtab.
     170
     171      call initstd;
     172      call initkey;
     173      call initlit;
     174
     175$ initialize trulex
     176      call initlex;
     177
     178      call initparse;  $ initialize parse
     179
     180
     181      end subr prsini;
       1 .=member initstd
       2      subr initstd;
       3
       4$ this routine initializes standard symbols used by the macro
smfb  19$ processor, such as 'macro'.  these must be the first entries
       6$ in symtab.
       7
       8
       9      size j(ps);             $ loop index
      10      size sym(ps);           $ symbol table pointer
      11
      12      size syms(.sds. 5);     $ symbols to be hashed into symtab
smfb  20      dims syms(11);
      14      data syms = 'macro', 'endm', 'drop',
      15                  ';', ',', '(', ')', ':=',
smfb  21                  'then', 'end', 'do';
      17
      18      size hashlit(ps);       $ hashes symbol into symbol table
      19
      20
smfb  22      do j = 1 to 11;
      22          sym = hashlit(syms(j));
      23      end do;
      24
      25
      26      end subr initstd;
       1 .=member initkey
       2      subr initkey;
       3
       4$ this routine initializes all the special lexical classes used
       5$ by the parser. it does this through a series of calls to the
       6$ lower level routine 'setkey'. each call to setkey processes
       7$ a dozen or so literals.
       8
       9$ setkey has three arguments, which are passed globally:
      10
      11$ the actual initialization is done by 'setkey', which has
      12$ two global inputs:
      13
      14$ key_lext:    gives the lex_typ of the tokens being initialized.
      15$ key_string:  a character string which drives the initiliation.
      16
      17$ key_string is a character string consisting of alternate integers
      18$ and keywords, separated by blanks. each integer indicates the
      19$ key_val of the keyword which follows it. a plus sign where an
      20$ integer is expected indicates that we should use the previous
      21$ integer, incremented by 1.
      22
      23
      24      nameset nsinitkey;
      25
      26          size key_lext(ps),
      27               key_string(.sds. 80);
      28
      29      end nameset nsinitkey;
      30
      31$ we use the following macro to call setkey
      32      +*  set(s) =
      33          key_string = s;
      34          call setkey;
      35          **
      36
      37
      38      $ declaration keywords
      39      key_lext = l_dkey;
      40      set('1 const + var + init ')
      41
      42      $ keywords for system defined modes
      43      key_lext = l_modekey;
      44      set('1 general + integer + real + string + boolean + atom ')
      45      set('7 error + elmt + tuple + set + smap + map + mmap ')
      46
      47      $ keywords for base types
      48      key_lext = l_btkey;
      49      set('1 local + remote + sparse + packed + untyped ')
      50
      51      $ keywords for statements
      52      key_lext = l_stkey;
      53      set('1 assert + case + continue + debug + exit ')
      54      set('6 fail + goto + if + loop + notrace + quit ')
      55      set('12 return + stop + succeed + trace + yield ')
      56
      57      $ keywords for read/write options
      58      key_lext = l_rwkey;
      59      set('1 rd + wr + rw ')
      60
      61      $ keywords for 'rights' list
      62      key_lext = l_rkey1;
      63      set('1 libraries + reads + writes ')
      64
      65      key_lext = l_rkey2;
      66      set('1 imports + exports ')
      67
      68      $ system defined binary operators
      69      key_lext = l_bin;
      70      set('1 impl 2 or 3 and 5 in 5 notin 5 incs 5 subset ')
      71      set('5 < 5 <= 5 > 5 >= 5 = 5 /= ')
      72      set('7 with 7 less 7 lessf 7 npow 7 min 7 max ')
      73      set('10 * 10 / 10 div 10 mod 10 ? 10 atan2 11 ** ')
      74      $
      75      key_lext = l_from;
      76      set('7 from 7 fromb 7 frome ');
      77
      78      $ system defined unary operators
      79      key_lext = l_un;
      80      set('4 not 6 even 6 odd 6 is_integer 6 is_real 6 is_string ')
      81      set('6 is_boolean 6 is_atom 6 is_tuple ')
      82      set('6 is_set 6 is_map 12 arb 12 domain 12 range 12 pow 12 # ')
      83      set('12 abs 12 char 12 ceil 12 floor 12 fix 12 float ')
      84      set('12 sin 12 cos 12 tan 12 asin 12 acos 12 atan 12 tanh ')
      85      set('12 exp 12 log 12 sqrt 12 random 12 sign 12 type ')
      86      set('12 str 12 val ')
      87
      88      $ system defined operators which are both unary and binary.
      89      $ their precedence is the precedence of the binary operator.
      90      key_lext = l_unbin;
      91      set('9 + 9 - ')
      92
      93      $ compiler debugging options
      94      key_lext = l_debug;
      95      set('1 ptrm0 + ptrm1 + ptrp0 + ptrp1 + ptrt0 + ptrt1 ')
      96      set('7 prsod + prspd + prssd ')
      97      set('10 stre0 + stre1 + strs0 + strs1 + sq1cd + sq1sd + scstd ')
      98      set('17 cq1cd + cq1sd + cq2cd ')
      99      set('20 rtre0 + rtre1 + rtrc0 + rtrc1 ')
     100      set('24 rtrg0 + rtrg1 + rgcd0 + rgcd1 + rdump + rgarb ')
     101
     102      $ user trace options
     103      key_lext = l_trace;
     104      set('1 calls + statements ')
     105
     106      macdrop(set);
     107
     108
     109      end subr initkey;
       1 .=member setkey
       2      subr setkey;
       3
       4$ this routine initializes a single group of keywords. its
       5$ arguments are passed globally as described in 'initkey'.
       6
       7$ the principle argument is a character string 'key_string'.
       8$ key_string consists of a series of tokens separated by a
       9$ single blank. numbering tokens from right to left, each odd
      10$ token is either:
      11
      12$ 1. an integer giving the key_val of the keyword which
      13$    immeditely follows it.
      14
      15$ 2. a plus sign, indicating that the new key_val is one more
      16$    than that of the previous keyword.
      17
      18$ the even numbered tokens are the keywords themselves.
      19
      20$ we loop along the string, finding each pair of tokens,
      21$ and setting the key_val of each keyword.
      22
      23
      24      size len(ps),  $ length of key_string
      25           val(ws), $ value of integer
      26           first(ps),  $ points to first character of token
      27           last(ps),   $ points to blank after token
      28           ch(cs),     $ current character
      29           keyw(.sds. 20),  $ current keyword
      30           sym(ps);         $ symbol table pointer to keyword
      31
      32      size hashlit(ps);  $ hashing function
      33
      34      access nsinitkey;
      35
      36
      37      first = 1;  $ start of first token
      38      val = 0;    $ initial keyword value
      39
      40      len = .len. key_string;
      41
      42      while first < len;
      43
      44          ch = .ch. first, key_string;
      45
      46          if ch = 1r+ then
      47              val = val + 1;
      48              first = first + 1;  $ point to blank
      49
      50          else $ convert integer
      51              val = 0;
      52
      53              while ch ^= 1r ;
      54                  val = 10 * val + digofchar(ch);
      55                  first = first + 1;
      56                  ch = .ch. first, key_string;
      57              end while;
      58          end if;
      59
      60$ first now points to the blank. find the keyword.
      61
      62          first = first + 1;  $ point to start of keyword
      63          last  = first + 1;  $ point to next character
      64
      65$ look for next blank
      66          while .ch. last, key_string ^= 1r ;
      67              last = last + 1;
      68          end while;
      69
      70$ 'last' now points to the blank after the keyword
      71
      72          keyw = .s. first, last-first, key_string;
      73          sym = hashlit(keyw);
      74
      75          lex_typ(sym) = key_lext;
      76          key_val(sym) = val;
      77
      78          first = last + 1;  $ start of next token.
      79      end while;
      80
      81
      82      end subr setkey;
       1 .=member initlit
       2      subr initlit;
       3
       4$ this routine initiailizes the literals contained in the grammar.
       5$ we use the results of 'syn' to create two arrays, which in turn
       6$ drive the initialization routine
       7
       8$ 1. lit_string    this is an array containing the actual literals
       9
      10$ 2. lit_code      this is an array containing the corresponding
      11$                  literal code lit_xxx.
      12
      13$ we iterate over the two arrays, hashing in each string and setting the
      14$ lit_val of the corresponding entry.
      15
      16$ note that there are more entries in lit_string than literals
      17$ in the grammar. this is because certain terminal symbols of the
      18$ grammar can be represented by one of several tokens.
      19
      20
      21 .=include synmax           $ this includes the macro parselitmax
      22
      23      size lit_string(.sds. 30);
      24      dims lit_string(parselitmax);
      25
      26      size lit_code(ps);
      27      dims lit_code(parselitmax);
      28
      29      size hashlit(ps);   $ hashing function
      30
      31 .=zzyorg a   $ counter for initilizing lit_string and lit_code
      32
      33      +*  synlitmap(string, code) =
      34          data lit_string(zzya) = string;
      35          data lit_code(zzya) = code;
      36          **
      37
      38 .=include 'synlit'  $ include synlitmap
      39
      40
      41      size j(ps),   $ loop index
      42           lit(.sds. 30),  $ current literal
      43           p(ps);          $ symbol table pointer to literal
      44
      45
      46      do j = 1 to parselitmax;
      47          lit = lit_string(j);
      48
      49 .+s66    if (lit = 2q::) lit = 1q: .cc. 1q:;
      50
      51          p = hashlit(lit);
      52
      53          lit_val(p) = lit_code(j);
      54      end do;
      55
      56
      57      end subr initlit;
       1 .=member inparse
       2      subr initparse;
       3
       4$ this routine defines the data structures for the parser. the
       5$ parser can be thought of as an interpreter for an abstract
       6$ parsing machine. the interpertable code is contained in the
       7$ table 'pt', and has the following fields:
       8
       9$ parse_op         an opcode po_xxx
      10$ parse_param      a single integer parameter
      11$ parse_parm1      a subfield of parse_param
      12$ parse_parm2      another subfield of parse_param
      13
      14$ the parse machine has two registers, represented by the array
      15$ parsereg. the first two registers have special purposes:
      16
      17$ reg. 1    indicates success of last parser operation
      18$ reg. 2    contains key_val of last keyword recognized.
      19
      20$ the variable 'parsep' points to the current instruction in 'pt'.
      21
      22$ the parse machine contains several instructions which are
      23$ essentially procedure calls. we handle procedure linkage
      24$ through a stack called 'rstack' (r-eturn stack). its fields are
      25
      26$ r_is_sev     $ indicates call from po_sev instruction
      27$ r_clause     $ starting address of desired clause
      28$ r_return     $ return address
      29$ r_number     $ number of clauses seen during  operation
      30
      31
      32$ 'parse' consists of an infinite loop with a case statement
      33$ which branches on the current opcode.
      34
      35
      36      nameset parsens;
      37
      38           +*  pt_op(i)      =  .f. 01, 04, pt(i)  **
      39           +*  pt_parm(i)    =  .f. 05, 12, pt(i)  **
      40           +*  pt_parm1(i)   =  .f. 05, 03, pt(i)  **
      41           +*  pt_parm2(i)   =  .f. 08, 09, pt(i)  **
      42
      43           size parsep(ps);  $ location counter
      44           data parsep = 1;
      45
      46           size parsereg(ps); $ registers
      47           dims parsereg(8);
      48           data parsereg = 0(8);
      49
      50           +*  parse_ok  = parsereg(1)  **  $ condition code
      51           +*  parse_tok = parsereg(2)  **  $ last token
      52
      53      +* rstack_sz  =         $ size of recursion stack
      54 .+s10    36
      55 .+s20    36
smfb  23 .+r32    64
      59 .+s66    60
      60          **
      61
      62          +*  rstack_lim  = 100  **  $ dimension of rstack
      63
      64      size rstack(rstack_sz); $ recursion stack
      65           dims rstack(rstack_lim);
      66
      67           size rstackp(ps);  $ pointer to top of rstack
      68           data rstackp = 0;
      69
      70 .+s10.
      71           +*  r_is_sev(i)    =  .f. 01, 01, rstack(i)  **
      72           +*  r_clause(i)    =  .f. 02, 11, rstack(i)  **
      73           +*  r_return(i)    =  .f. 13, 11, rstack(i)  **
      74           +*  r_number(i)    =  .f. 25, 08, rstack(i)  **
      75 ..s10
      76
      77 .+s20.
      78           +*  r_is_sev(i)    =  .f. 01, 01, rstack(i)  **
      79           +*  r_clause(i)    =  .f. 02, 11, rstack(i)  **
      80           +*  r_return(i)    =  .f. 13, 11, rstack(i)  **
      81           +*  r_number(i)    =  .f. 25, 08, rstack(i)  **
      82 ..s20
      83
      84
smfb  24 .+r32.
      86           +*  r_is_sev(i)    =  .f. 01, 01, rstack(i)  **
      87           +*  r_clause(i)    =  .f. 17, 16, rstack(i)  **
      88           +*  r_return(i)    =  .f. 33, 16, rstack(i)  **
      89           +*  r_number(i)    =  .f. 49, 16, rstack(i)  **
smfb  25 ..r32
     104
     105 .+s66.
     106           +*  r_is_sev(i)    =  .f. 01, 01, rstack(i)  **
     107           +*  r_clause(i)    =  .f. 02, 11, rstack(i)  **
     108           +*  r_return(i)    =  .f. 13, 11, rstack(i)  **
     109           +*  r_number(i)    =  .f. 25, 08, rstack(i)  **
     110 ..s66
     111
     112
     113      +* r_num_lim  =         $ limit for r_number
     114 .+s10    255
     115 .+s20    255
smfb  26 .+r32    65535
     119 .+s66    255
     120          **
     121
     122
     123$ the parser has the following opcodes:
     124
     125 .=zzyorg z
     126
     127            defc(po_act)   $ call separate routine
     128            defc(po_bak)   $ return from interpreter call
     129            defc(po_err)   $ emit error message
     130            defc(po_jif)   $ branch on parse_ok = no.
     131            defc(po_jmp)   $ jump
     132            defc(po_lex)   $ find lexical type
     133            defc(po_lit)   $ find literal
     134            defc(po_set)   $ set register
     135            defc(po_sev)   $ call to find several clauses
     136            defc(po_sub)   $ call to find 1 clause
     137            defc(po_skip)   $ branch on keyword
     138            defc(po_save)  $ save parser status
     139            defc(po_nosave) $ pop saved status
     140            defc(po_restore) $ restore saved status
     141            defc(po_m)       $ emit marker
     142
     143            +*  po_min   =  po_act  **
     144            +*  po_max   =  po_m    **
     145
     146      end nameset;
     147
     148
     149      nameset backup;
smfb  27
     150$ this nameset contains the variables which implement backtracking
     151$ in the parser. these include:
     152
     153$ 1. sstack:
     154
     155$    this is a stack for saving parser states. its fields are
     156
     157$    s_polp:     saves pointer to polish string
     158$    s_xpolp:    saves pointer to auxiliary string
     159$    s_tout:     saves pointer to token buffer
     160$    s_stat:     saves statement counter
     161
     162$ 2. tok_buff:
     163
     164$    this is a circular buffer used to save tokens. its related
     165$    variables are:
     166
     167$    tok_in:    points to last token added to buffer
     168$    tok_out:   points to last token returned to parser
     169
     170$ tok_buff is manipulated by the scanner-interface routine 'gettok'.
     171
     172          +*  sstack_sz   =          $ size of string
     177 .+s10        72
     178 .+s20        72
smfb  28 .+r32        128
smfb  29 .+s66        60
     179              **
     180
     181          +*  sstack_lim  =  50  **  $ number of saved states
     182
     183          size sstack(sstack_sz);
     184          dims sstack(sstack_lim);
     185
     186          size sstackp(ps);
     187          data sstackp = 0;
     188
     189 .+s66.
     191          +*  s_polp(i)   =  .f. 01, 15, sstack(i)  **
     192          +*  s_xpolp(i)  =  .f. 16, 15, sstack(i)  **
     193          +*  s_tout(i)   =  .f. 31, 15, sstack(i)  **
     194          +*  s_stat(i)   =  .f. 46, 15, sstack(i)  **
     195 ..s66
     204
smfb  30 .+r32.
     207          +*  s_polp(i)   =  .f. 01, 32, sstack(i)  **
     208          +*  s_xpolp(i)  =  .f. 33, 32, sstack(i)  **
     209          +*  s_tout(i)   =  .f. 65, 32, sstack(i)  **
     210          +*  s_stat(i)   =  .f. 97, 32, sstack(i)  **
smfb  31 ..r32
     221
     222 .+s10.
     224          +*  s_polp(i)   =  .f. 01, 18, sstack(i)  **
     225          +*  s_xpolp(i)  =  .f. 19, 18, sstack(i)  **
     226          +*  s_tout(i)   =  .f. 37, 18, sstack(i)  **
     227          +*  s_stat(i)   =  .f. 55, 18, sstack(i)  **
     228 ..s10
     229
     230 .+s20.
     232          +*  s_polp(i)   =  .f. 01, 18, sstack(i)  **
     233          +*  s_xpolp(i)  =  .f. 19, 18, sstack(i)  **
     234          +*  s_tout(i)   =  .f. 37, 18, sstack(i)  **
     235          +*  s_stat(i)   =  .f. 55, 18, sstack(i)  **
     236 ..s20
     237
     238
     239
     240          +*  tok_lim  =  500  **  $ maximum saved tokens
     241
     242          size tok_buff(ps);
     243          dims tok_buff(tok_lim);
     244
     245          size tok_in(ps);
     246          data tok_in = 0;
     247
     248          size tok_out(ps);
     249          data tok_out = 0;
     250      end nameset;
     251
     252      size j(ps);   $ loop index for initialization
     253
     254      call ptinit;  $ initialize parse table.
     255
     256$ initialize parsep and parse_ok
     257      parsep = 1;
     258      parse_ok = yes;
     259
     260
     261      end subr initparse;
       1 .=member ptinit
       2
       3
       4 .-defenv_ptinit.
       5
       6
       7      subr ptinit;
       8
       9$ initialize parse table by reading it in.
      10
      11$ the default version of ptinit reads in the parse table.
      12$ the parse table for setl is too large to permit compiling
      13$ the data statements that would be required to initialize
      14$ the table due to limitations of the little compiler.
      15$ however, some systems may be able to use the option of the
      16$ syn program by which the table is represented in form that
      17$ permits initialization by assembly language data statements,
      18$ and such systems can use defenv_ptinit option to avoid need
      19$ to read in parse table.
      20
      21
      22      size  syn_title(.sds.30);  $ title for 'syn' file.
      23
      24 .+s66   call getspp(syn_title,   'syn=synbin/synout');
      25 .+s37   call getspp(syn_title,   'syn=synbin/synout');
      26 .+s47   call getspp(syn_title,   'syn=synbin/synout');
      27 .+s32   call getspp(syn_title,   'syn=synbin.dat/synout.dat');
      28 .+s10   call getspp(syn_title,   'syn=synbin/synout');
      29 .+s20   call getspp(syn_title,   'syn=synbin/synout');
suna  23 .+s68   call getspp(syn_title,   'syn=synbin/');
      30
      31      file syn_file
      32          access = read,
      33          title = syn_title;
      34
      35      rewind syn_file;
      36
      37      read syn_file, pt(1) to pt(parsearamax);
      38
      39      file syn_file access=release;
      40
      41
      42      end subr ptinit;
      43
      44
      45 ..defenv_ptinit
      46
      47
       1 .=member parse
       2      subr parse;
       3
       4$ this is the actual parser. its operation is described in
       5$ initparse, above.
       6
       7      access parsens, backup;
       8
       9      size op(ps),    $ current opcode
      10           parm(ps), $ current parameter
      11           i(ps),  $ register number
      12           j(ps),  $ register value
      13           tok(ps),   $ token obtained from scanner
      14           junk(ps);  $ disgarded type code from polish
      15      size tp(ps);            $ type of current token
      16
      17      size gettok(ps); $ lexical scanner
      18
      19
      20      while 1;   $ main loop
      21
      22          op = pt_op(parsep);
      23          parm = pt_parm(parsep);
      24
      25          if pt_flag then  $ tracing parser
      26              put, skip, column(7), 'parsep: ': parsep, i,
      27                   column(20), 'op: ': op, i,
      28                   column(30), 'parm: ': parm, i;
      29          end if;
      30
      31          go to case(op) in po_min to po_max;
      32
      33      /case(po_lit)/    $ test for matching literal
      34
      35$ literals are identified by
      36
      37$ lit_val:     should be equal to 'parm'.
      38
      39$ a 'find literal' instruction is always the first of three
      40$ instructions
      41
      42$ 1. find literal
      43$ 2. branch on failure
      44$ 3. next action on success
      45
      46$ if we are successful, we increment parsep to point to (3).
      47$ otherwise we increment it to point to (2).
      48
      49          parse_tok = gettok(0);
      50
      51          if lit_val(parse_tok) = parm & ^ eof_flag then
      52              parse_ok = yes;
      53              parsep = parsep + 2;
      54          else
      55              parse_ok = no;
      56
      57              tok_out = tok_out - 1;  $ return token to buffer
      58              if (tok_out = 0) tok_out = tok_lim;
      59
      60              parsep = parsep + 1;
      61          end if;
      62
      63          cont;
      64
      65
      66      /case(po_lex)/    $ find desired lexical type
      67
      68$ a tokens lexical type is given by its 'lex_typ' field.
      69$ if the token has the proper type, we write it onto the polish
      70$ string and advance parsep by 2. otherwise we return it and
      71$ advance parsep by 1.
      72
      73          parse_tok = gettok(0);   tp = lex_typ(parse_tok);
      74
      75          if ^ eof_flag & parm = tp then
      76              parse_ok = yes;
      77
      78              putp(name(parse_tok), pol_name);
      79              parsep = parsep + 2;
      80
      81          else
      82              parse_ok = no;
      83
      84              tok_out = tok_out-1;  $ return token
      85              if (tok_out = 0) tok_out = tok_lim;
      86
      87              parsep = parsep + 1;
      88          end if;
      89
      90          cont;
      91
      92      /case(po_sev)/     $ 'procedure calls' to find clauses
      93
      94      /case(po_sub)/
      95
      96$ po_sev corresponds to the construct  in the grammar,
      97$ and seeks several instances of a clause. po_sub corresponds
      98$ to  and seeks a single instance.
      99
     100          countup(rstackp, rstack_lim, 'rstack');
     101
     102          r_is_sev(rstackp) = (op = po_sev);
     103          r_clause(rstackp) = parm;
     104          r_return(rstackp) = parsep + 1;
     105          r_number(rstackp) = 0;
     106
     107          parsep = parm;
     108          cont;
     109
     110
     111      /case(po_bak)/    $ return from  or 
     112
     113$ the action we take here depends on whether we are looking
     114$ for one clause or several.
     115
     116$ if we are looking for one clause, we return unconditionally. if
     117$ we are looking for several clauses, we take one of two actions:
     118
     119$ 1. if we have been successful so far, look for another clause.
     120$ 2. otherwise write the number of clauses found onto the
     121$    polish string and return.
     122
     123$ if rstack is empty, we have parsed a sentence symbol.  if the
     124$ input file is exhausted, we return;  otherwise -chkprs- has done
     125$ the necessary recovery, and we continue to parse.
     126
     127          if rstackp = 0 then
     128              call chkprs;
     129              if (eof_flag) return;
     130
     131              cont;
     132
     133
     134          elseif r_is_sev(rstackp) then   $ return from 
     135
     136              if parse_ok then  $ look for another
     137                  countup(r_number(rstackp), r_num_lim, '');
     138                  parsep = r_clause(rstackp);
     139
     140              else  $ write marker and return success
     141                  putp(r_number(rstackp), pol_count);
     142                  parse_ok = yes;
     143                  parsep = r_return(rstackp);
     144                  rstackp = rstackp-1;
     145              end if;
     146
     147          else   $ return from 
     148              parsep = r_return(rstackp);
     149              if (parse_ok) parsep = parsep + 1;
     150              rstackp = rstackp-1;
     151          end if;
     152
     153          cont;
     154
     155
     156      /case(po_err)/   $ issue error message
     157
     158$ if the condition code is true we merely advance. otherwise we
     159$ call 'ermet', which prints the error message and resets the
     160$ parser.
     161
     162          if parse_ok then
     163              parsep = parsep + 1;
     164          else
     165              call ermet(parm);
     166          end if;
     167
     168          cont;
     169
     170
     171      /case(po_jif)/     $ conditional jump  -lab
     172
     173          if parse_ok then
     174              parsep = parsep + 1;
     175          else
     176              parsep = parm;
     177          end if;
     178
     179          cont;
     180
     181
     182      /case(po_jmp)/   $ go to    +lab
     183
     184          parsep = parm;
     185          cont;
     186
     187
     188      /case(po_set)/    $ set register i to j
     189
     190          i = pt_parm1(parsep) + 1;
     191          j = pt_parm2(parsep);
     192
     193          parsereg(i) = j;
     194
     195          parsep = parsep + 1;
     196          cont;
     197
     198
     199      /case(po_skip)/    $ branch on keyword
     200
     201          parsep = parsep + key_val(parse_tok);
     202          cont;
     203
     204
     205      /case(po_save)/     $ save parser status
     206
     207          countup(sstackp, sstack_lim, 'save');
     208
     209          s_polp(sstackp)  = polp;
     210          s_xpolp(sstackp) = xpolp;
     211          s_tout(sstackp)  = tok_out;
     212          s_stat(sstackp)  = cstmt_count;
     213
     214          parsep = parsep + 1;
     215          cont;
     216
     217
     218      /case(po_nosave)/    $ disgard saved status
     219
     220          sstackp = sstackp-1;
     221          parsep = parsep + 1;
     222          cont;
     223
     224
     225      /case(po_restore)/    $ restore parser to saved status
     226
     227          polp        = s_polp(sstackp);
     228          xpolp       = s_xpolp(sstackp);
     229          tok_out     = s_tout(sstackp);
     230          cstmt_count = s_stat(sstackp);
     231
     232          sstackp = sstackp-1;
     233
     234          parsep = parsep + 1;
     235          cont;
     236
     237
     238      /case(po_m)/    $ write marker
     239
     240          putp(parm, pol_mark);
     241          parsep = parsep + 1;
     242          cont;
     243
     244
     245      /case(po_act)/   $ call generator routine
     246
     247          call actgen(parm);
     248          parsep = parsep + 1;
     249          cont;
     250
     251
     252      end while;
     253
     254      end subr parse;
       1 .=member actgen
       2      subr actgen(parm);
       3
       4$ this routine performs generated actions specified in the
       5$ grammar. the actual generator calls are included from the
       6$ output of 'syn'.
       7
       8      size parm(ps);
       9
      10      +*  pac  =  go to esac;  **   $ utility macro
      11
      12
      13      go to pa(parm) in 1 to parseactmax;
      14
      15 .=include 'synact'    $ include generator calls
      16
      17/esac/      $ end of case
      18
      19      return;
      20
      21      end subr actgen;
       1 .=member gettok
       2      fnct gettok(dummy);
       3
       4$ this routine acts as an interface bewteen the scanner and the parser.
       5$ it returns the next token in the input stream.
       6
       7$ gettok maintains a buffer of tokens obtained from the scanner.
       8$ this is used to implement backtracking in the parser.
       9
      10
      11$ the token buffer is circular. when we enter gettok we begin by
      12$ checking whether the buffer is empty(in pointer = out pointer).
      13$ if so, we get a token from the scanner and insert it in the buffer.
      14
      15$ once we know the buffer is non-empty, we merely return the first
      16$ token in the buffer.
      17
      18$ at certain points in the parse, we must save the status of the parser.
      19$ one of the variables saved is a pointer to the token buffer indicating
      20$ the last token returned. every time we add a token to the buffer, we
      21$ must make sure that we do not clobber the oldest token which is part
      22$ of a saved state.
      23
      24
      25      size tok(ps);   $ current token
      26
      27      size gettok(ps),  $ token returned
      28           lexscan(ps),  $ lower level scanner routine
      29           symsds(sds_sz);  $ gets token name
      30
      31      access backup;  $ nameset containing token buffer
      32
      33
      34      if tok_in = tok_out then   $ buffer empty
      35          tok_in = tok_in + 1;
      36          if (tok_in > tok_lim) tok_in = 1;
      37
      38          if sstackp ^= 0 then  $ saving parser states
      39              if (tok_in = s_tout(1)) call overfl('tok_buff');
      40          end if;
      41
      42          tok_buff(tok_in) = 0;    $ not yet found
      43          tok = lexscan(0);   $ get token from scanner
      44          tok_buff(tok_in) = tok;
      45
      46      end if;
      47
      48      tok_out = tok_out + 1;   $ remove token
      49      if (tok_out > tok_lim) tok_out = 1;
      50
      51      gettok = tok_buff(tok_out);
      52
      53      if tt_flag then  $ tracing tokens output by gettok
      54          put, skip, column(7), 'gettok = ': symsds(gettok), a;
      55      end if;
      56
      57
      58      end fnct gettok;
       1 .=member lexscan
       2      fnct lexscan(dummy);
       3
       4$ this is the top level routine of the macro processor. it
       5$ returns a token from the next routine down, intercepting
       6$ macro occurrences.
       7
       8$ when we see a macro occurrence, we call 'initexp' which
       9$ initiates expansion of the macro.
      10
      11
      12      size lexscan(ps),  $ value returned
      13           absorb(ps);   $ lower level scanner routine
      14
      15
      16      while 1;
      17          lexscan = absorb(0);
      18
      19          if eof_flag then  $ end of file
      20              return;
      21
      22          elseif morg(lexscan) = 0 then  $ not macro
      23              return;
      24
      25          else
      26              call initexp(lexscan);  $ collect arguments and try again
      27          end if;
      28
      29      end while;
      30
      31
      32      end fnct lexscan;
       1 .=member initexp
       2      subr initexp(nam);
       3
       4$ this routine is called to initiate expansion of the macro 'nam'.
       5$ we begin by checking whther the macro has arguments. if not,
       6$ we simply build a new stack frame. otherwise we collect the
       7$ macros arguments by calling absorb, then build the stack
       8$ frame.
       9
      10
      11      size nam(ps);   $ name of macro
      12
      13      size n(ps),  $ number of arguments
      14           nparen(ps), $ no of parens
      15           tok(ps),  $ current token
      16           delim(ps),  $ desired delimiter
      17           j(ps);  $ loop index
      18
      19      size args(ps);   $ array of astack pointers
      20      dims args(param_lim);
      21
      22      size absorb(ps);  $ lower level scanner routine
      23
      24
      25      n = margs(nam);  $ get number of arguments
      26
      27      if n = 0 then  $ no arguments
      28          mstackp = mstackp+2;
      29          if (mstackp > mstack_lim) call overfl('mstack');
      30
      31          mstack(mstackp) = morg(nam);
      32          mstack(mstackp-1) = 0;
      33
      34          return;
      35
      36      end if;
      37
      38
      39$ otherwise collect the macros arguments. we do this by calling
      40$ 'absorb' for tokens. as we get each token, we add it to the argument
      41$ buffer 'astack'. we save a pointer to the first astack entry for
      42$ each argument in an auxilliary table called 'args'. these pointers
      43$ are later used to build the stack frame.
      44
      45      if (absorb(0) ^= sym_lp) call ermsg(1, 0);  $ get leading '('
      46
      47      do j = 1 to n;   $ collect arguments
      48
      49          args(j) = astackp+1;  $ save pointer to argument
      50          nparen = 0;           $ depth of parenthesis
      51
      52          while 1;
      53              tok = absorb(0);
      54
      55              if eof_flag then  $ end of file
      56                  call eofr;
      57
      58              elseif tok = sym_lp then  $ left paren
      59                  nparen = nparen + 1;
      60
      61              elseif tok = sym_rp then  $ right paren
      62                  if (nparen = 0) quit;   $ end of argument list
      63                  nparen = nparen - 1;
      64
      65              elseif nparen = 0 & tok = sym_comma then  $ end of argumen
      66                  quit;
      67              end if;
      68
      69$ add token to astack.
      70              countup(astackp, astack_lim, 'astack');
      71              astack(astackp) = tok;
      72          end while;
      73
      74$ push a zero onto astack to indicate end of argument
      75          countup(astackp, astack_lim, 'astack');
      76          astack(astackp) = 0;
      77
      78$ check that we found the right delimiter
      79          if j = n then
      80              delim = sym_rp;
      81          else
      82              delim = sym_comma;
      83          end if;
      84
      85          if (delim ^= tok) call ermsg(2, nam);
      86      end do;
      87
      88$ build stack frame
      89      mstackp = mstackp + n + 2;
      90      if (mstackp > mstack_lim) call overfl('mstack');
      91
      92      mstack(mstackp) = morg(nam);
      93      mstack(mstackp-1) = n;
      94
      95      do j = 1 to n;
      96          mstack(mstackp-1-j) = args(j);
      97      end do;
      98
      99
     100      end subr initexp;
       1 .=member absorb
       2      fnct absorb(dummy);
       3
       4$ this is the second level of the macro processor. it passes along
       5$ tokens, intercepting macro drops and definitions.
       6
       7
       8      size absorb(ps),  $ value returned
       9           expand(ps);  $ lower level scanner routine
      10
      11
      12      while 1;
      13          absorb = expand(0);   $ obtain token
      14
      15          if eof_flag then  $ end of file
      16              return;
      17
      18          elseif absorb = sym_macro then
      19              call getdef;
      20
      21          elseif absorb = sym_drop then
      22              call getdrop;
      23
      24          else
      25              quit;
      26          end if;
      27
      28      end while;
      29
      30
      31      end fnct absorb;
       1 .=member getdef
       2      subr getdef;
       3
       4$ this routine processes macro definitions. this is handled in three
       5$ steps:
       6
       7$ 1. get the macro name and store it in the global 'new_mac'.
       8
       9$ 2. get the formal parameters and set the margs field of the
      10$    macro.
      11
      12$ 3. get the macro text and set the morg field of the macro.
      13
      14
      15      size mac(ps);   $ macro name
      16
      17      size expand(ps);  $ lower level scanner routine
      18
      19
      20      mac = expand(0);
      21
      22      if eof_flag then  $ end of file
      23          call eofr;
      24
      25      elseif lex_typ(mac) > l_bold then  $ illegal token type
      26          call ermsg(3, mac);
      27          return;
      28
      29      elseif morg(mac) ^= 0 then  $ redefinition
      30          call ermsg(4, mac);
      31      end if;
      32
      33      call getparms(mac);  $ get parameter list
      34      call gettext(mac);  $ get text
      35
      36
      37      end subr getdef;
       1 .=member getparms
       2      subr getparms(mac);
       3
       4$ this routine collects the formal parameters for the macro 'mac'.
       5$ we do this by calling 'expand' to get tokens and parsing the
       6$ parameter list. as we recognize each parameter, we do three
       7$ things:
       8
       9$ 1. check for duplicate parameters.
      10$ 2. enter the parameter name in the array 'params'.
      11$ 3. set the 'mcode' field of the parameter to indicate
      12$    how the parameter will be represented in the macros text.
      13
      14$ once we have processed all the parameters, we set the
      15$ margs field of the macro to indicate the number of
      16$ arguments.
      17
      18$ the mcode field is used to indicate the representation of arguments
      19$ in the macro text. the mcode field is initially zero, indicating
      20$ straight text, and is reset while we are processing each macro
      21$ definition. after we absorb the text we must reset the mcode
      22$ field of each of the parameters to 0.
      23
      24
      25      size mac(ps);  $ macro name
      26
      27      size delim(ps),  $ delimiter
      28           nuser(ps),  $ no. of user args
      29           ngen(ps),   $ no. of generated arguments
      30           semi_seen(1),  $ on if ';' has been seen
      31           tok(ps),  $ current token
      32           param(ps);   $ current parameter
      33
      34      size expand(ps);  $ lower level scanner function
      35
      36
      37$ we begin by checking whether the macro name is followed by a
      38$ semi-colon. if so, there are no arguments.
      39
      40      delim = expand(0);
      41
      42      if eof_flag then  $ end of file
      43          call eofr;
      44
      45      elseif delim = sym_semi then  $ macro with no arguments
      46          margs(mac) = 0;
      47          paramsp = 0;  $ indicate params is empty.
      48          return;
      49
      50      elseif delim ^= sym_lp then
      51          call ermsg(5, 0);
      52      end if;
      53
      54      nuser = 0;   $ number of user supplied arguments
      55      ngen = 0;    $ number of generated arguments
      56
      57      paramsp = 0;
      58
      59$ see if the left paren is followed by a semicolon. if so, there are
      60$ no user supplied arguments.
      61
      62      tok = expand(0);
      63
      64      if tok = sym_semi then
      65          semi_seen = yes;
      66      else
      67          semi_seen = no;
      68          expand_buff = tok;  $ return token
      69      end if;
      70
      71      while 1;
      72          param = expand(0);
      73
      74          if eof_flag then  $ end of file
      75              call eofr;
      76
      77          elseif mcode(param) ^= 0 then  $ duplicate argument
      78              call ermsg(6, param);
      79
      80          elseif semi_seen then  $ generated argument
      81              ngen = ngen + 1;
      82              mcode(param) = bias_gen1 + ngen;
      83
      84          else  $ user supplied argument
      85              nuser = nuser + 1;
      86              mcode(param) = bias_user + nuser;
      87          end if;
      88
      89$ store in set of parameters
      90          countup(paramsp, param_lim, 'params');
      91          params(paramsp) = param;
      92
      93          delim = expand(0);
      94
      95          if eof_flag then  $ end of file
      96              call eofr;
      97
      98          elseif delim = sym_rp then  $ end of list
      99              quit;
     100
     101          elseif delim = sym_semi then
     102              if (semi_seen) call ermsg(7, 0);
     103              semi_seen = yes;
     104
     105          elseif delim ^= sym_comma then
     106              call ermsg(8, 0);
     107          end if;
     108
     109      end while;
     110
     111      margs(mac) = nuser;  $ set no. of args
     112
     113      if (expand(0) ^= sym_semi) call ermsg(9, 0); $ trailing ';'
     114
     115
     116      end subr getparms;
       1 .=member gettext
       2      subr gettext(mac);
       3
       4$ this routine gets the text for the macro 'mac'. this is done
       5$ by getting tokens from the macro expander and adding them to
       6$ mttab until the end of the macro is encountered.
       7
       8$ as we get each token, we examine it to see if we have reached
       9$ the end of the macro. there are two ways to indicate the
      10$ end of a macro:
      11
      12$     endm mac;     or       endm;
      13
      14$ the word 'endm' alone is only recognized as the end of the
      15$ macro if the macro text contains an equal number of imbedded
      16$ 'macro'-s and 'endm'-s.
      17
      18$ we keep track of the length of the macro. if it exceeds a
      19$ certain length, we assume that there is a missing 'endm'.
      20
      21$ note that parameters and generated arguments recieve a
      22$ special representation in the macro text. this representation
      23$ is given by the mcode field of their symbol table entries.
      24$ a mcode field of zero indicates simple text; this is
      25$ represented directly by a symbol table pointer.
      26
      27$ once we have gathered all the text, we must clear the mcode
      28$ fields of the parameters. we use the set 'params' to do this.
      29
      30
      31      size mac(ps);   $ macro name
      32
      33      size len(ps),  $ length of macro
      34           lev(ps),  $ nesting depth for nested macros
      35           code(ps),   $ encoding of word of macro text
      36           j(ps),  $ loop index
      37           tok(ps),  $ current token
      38           tok1(ps), $ extra token
      39           param(ps);  $ parameter name
      40
      41      size expand(ps);  $ lower level scanner routine
      42
      43
      44      morg(mac) = mtabp + 1;   $ set origin field
      45
      46      len = 0;   $ length of macro
      47      lev = 0;  $ depth of nexting of macros
      48
      49      while 1;
      50          len = len+1;
      51
      52          if len > mlen_lim then
      53              call ermsg(10, 0);
      54              quit;
      55          end if;
      56
      57          tok = expand(0);
      58
      59          if eof_flag then  $ end of file
      60              call eofr;
      61
      62          elseif tok = sym_macro then  $ nested macro definitions
      63              lev = lev + 1;
      64
      65          elseif tok = sym_endm then  $ end of some macro
      66              if (lev = 0) quit;
      67              lev = lev-1;      $ decrement nesting depth
      68
      69              tok1 = expand(0);  $ look for 'endm mac'
      70              if (tok1 = mac) quit;
      71              expand_buff = tok1;  $ return token
      72
      73          elseif tok = mac then $ macro name occurs within itself
      74              call ermsg(11, mac);
      75          end if;
      76
      77
      78$ find out how we will encode the token in mtab. if the tokens
      79$ mcode is zero, then the token is straight text, and we simply
      80$ use its symbol table pointer. otherwise the token is an argument,
      81$ and mcode gives its encoding.
      82
      83$ each generated argument has one encoding on its first occurrence and
      84$ another on all later occurrences. after getting the code of the token,
      85$ see if it is a first occurrence of a generated argument. if so,
      86$ change its mcode field to indicate its encoding on all later
      87$ occurrences.
      88
      89          code = mcode(tok);
      90
      91          if code = 0 then  $ simple text
      92              code = tok;
      93
      94          elseif code > bias_gen1 & code < bias_gen2 then
      95              mcode(tok) = code + (bias_gen2 - bias_gen1);
      96          end if;
      97
      98          countup(mtabp, mtab_lim, 'mtab');
      99          mtab(mtabp) = code;
     100
     101$ adjust code for generated arguments
     102      end while;
     103
     104$ add zero entry to macro text
     105      countup(mtabp, mtab_lim, 'mtab');
     106      mtab(mtabp) = 0;
     107
     108$ get trailing tokens after 'endm'
     109      until eof_flag ! tok = sym_semi;
     110          tok = expand(0);
     111      end until;
     112
     113$ reset encoding for parameters
     114      do j = 1 to paramsp;
     115          param = params(j);
     116          mcode(param) = 0;
     117      end do;
     118
     119
     120      end subr gettext;
       1 .=member getdrop
       2      subr getdrop;
       3
       4$ this routine processes the 'macro drop' statement. this statement
       5$ has the form:
       6
       7$    drop  ;
       8
       9$ we iterate until we see a semicolon, dropping macros.
      10
      11
      12      size mac(ps),  $ macro name
      13           delim(ps);  $ delimeter
      14
      15      size expand(ps);  $ lower level scanner routine
      16
      17
      18      while 1;
      19          mac = expand(0);
      20
      21          if eof_flag then  $ end of file
      22              call eofr;
      23          elseif lex_typ(mac) > l_bold then  $ not valid macro name
      24              call ermsg(12, mac);
      25          else
      26              morg(mac) = 0;
      27              margs(mac) = 0;
      28          end if;
      29
      30          delim = expand(0);
      31
      32          if eof_flag then  $ end of file
      33              call eofr;
      34          elseif delim = sym_semi then
      35              return;
      36          elseif delim ^= sym_comma then
      37              call ermsg(13, 0);
      38          end if;
      39
      40      end while;
      41
      42
      43      end subr getdrop;
       1 .=member expand
       2      fnct expand(dummy);
       3
       4$ this is the bottom level routine of the macro expander. it
       5$ checks mstack to see whether we are currently expanding macros.
       6$ if so, it returns the next token of macro text; otherwise
       7$ it gets a token from the scanner.
       8
       9$ in order to parse macro definitions, we keep a one token
      10$ buffer. if this buffer contains a token, we return it.
      11$ otherwise loop until we can return a token, expanding macro
      12$ arguments where necessary.
      13
      14
      15      size p(ps),  $ pointer to mtab or astack
      16           n(ps),  $ number of arguments
      17           arg(ps);  $ pointer to astack
      18
      19      size expand(ps),  $ token returned
      20           trulex(ps),  $ lower level scanner routine
      21           bldgen(ps);  $ builds generated arguments
      22
      23
      24$ begin by checking 1 word buffer.
      25
      26      if expand_buff ^= 0 then  $ return saved token
      27          expand = expand_buff;
      28          expand_buff = 0;
      29          return;
      30      end if;
      31
      32$ otherwise loop until we can return a token of macro text
      33
      34      while 1;
      35
      36          if mstackp = 0 then  $ not expanding any macros
      37              expand = trulex(0);
      38              return;
      39          end if;
      40
      41$ get pointer to next word of macro text, then advance mstack.
      42          p = mstack(mstackp);
      43          mstack(mstackp) = p+1;
      44
      45$ p points to the next word of text in either astack or mtab.
      46$ if p is greater than 'mtab_lim' then it is a pointer into
      47$ astack biased by mtab_lim.
      48
      49          if p > mtab_lim then
      50              expand = astack(p-mtab_lim);
      51          else
      52              expand = mtab(p);
      53          end if;
      54
      55          if expand = 0 then  $ end of macro or argument. pop mstack.
      56              n = mstack(mstackp-1);   $ no. of args
      57
      58              if n ^= 0 then   $ pop astack
      59                  astackp = mstack(mstackp-2)-1;
      60              end if;
      61
      62              mstackp = mstackp-n-2;  $ pop mstack
      63
      64          elseif expand <= symtab_lim then $ simple text
      65              return;
      66
      67          elseif expand <= bias_gen1 then $ user argument
      68
      69$ get a pointer to the start of the argument in astack, then
      70$ build a stack frame.
      71
      72              n = expand-bias_user;  $ argument number
      73              arg = mstack(mstackp-1-n);  $ pointer to astack
      74
      75              mstackp = mstackp + 2;  $ build stack frame
      76              if (mstackp > mstack_lim) call overfl('mstack');
      77
      78              mstack(mstackp) = arg + mtab_lim;  $ store biased pointer
      79              mstack(mstackp-1) = 0;
      80
      81          elseif expand <= bias_gen2 then $ first use of gen. arg.
      82              expand = bldgen(expand-bias_gen1, yes);
      83              return;
      84
      85          else  $ second use of generated argument
      86              expand = bldgen(expand-bias_gen2, no);
      87              return;
      88          end if;
      89
      90      end while;
      91
      92
      93      end fnct expand;
       1 .=member trulex
       2      fnct trulex(dummy);
       3
       4$ this routine is the actual lexical scanner.  it returns the next
       5$ token from the input file.
       6$
       7$ trulex is essentially a giant case statement which brances on the
       8$ class of the first character in the token. each branch of the case
       9$ statement contains a separate loop for gathering the remainder
      10$ of the token.
      11$
      12$ the global variable 'char' always contains the next character of
      13$ the input file. there are several primitives for manipulating
      14$ 'char':
      15$
      16$ 1. getc:    advances 'char' to the next character
      17$ 2. backc:   removes last character from token.
      18$ 3. keepc:   adds 'char' to the token being built up.
      19$
      20$ the current card image is stored in a self defining string called
      21$ 'card' with a standard origin. the number of characters per line
      22$ is given by the macro 'cpc'. only the first 'scpc' characters
      23$ are significant; the remaining characters are used for sequence
      24$ numbers, etc.
      25$
      26$ the current token is stored as an array of characters called
      27$ 'tok'. it is converted to an sds before it is hashed.
      28$
      29$ the flag 'eof_flag' is set when the end of the input file is
      30$ encountered. it is checked every time we start processing a
      31$ new token.
      32$
      33$ once the end of file has been encountered, 'getc' always returns
      34$ a blank as the next character. the blank will act as a delimiter
      35$ for names, etc. without requiring a separate end of file check
      36$ within most of the loops.
      37
      38      +*  card_org  =   $ sorg for 'card'
      39          (.sds. cpc + 1)
      40          **
      41
      42
      43      +*  card_char(i)  =   $ i-th character of current line
      44          .f. card_org - (i*cs), cs, card
      45          **
      46
      47
      48      +*  keepc =   $ store character in 'tok'
      49          tok_pos = tok_pos + 1;
      50          if (tok_pos > toklen_lim) call tok_over;
      51          tok(tok_pos) = char;
      52          **
      53
      54
      55$ the following macro is used to back up char, tok_pos, and
      56$ card_pos. we will only back up as far as the start of
      57$ the current token, so there is never any need to retreat to
      58$ the previous line.
      59
      60      +*  backc =
      61          char = tok(tok_pos);
      62          tok_pos = tok_pos-1;
      63          card_pos = card_pos-1;
      64          **
smfa  13
smfa  14
smfa  15$ we define a standard code block at the end of this routine to get the
smfa  16$ next character from the input stream.  the following macro is used to
smfa  17$ simulate the internal procedure call.
smfa  18
smfa  19      +* l_call(lab)  =       $ local call to code block at label -lab-
smfa  20          retpt = zzya;       $ save return label
smfa  21          go to lab;          $ branch to internal procedure
smfa  22          /rlab(zzya)/        $ define label for return point
smfa  23          **
smfa  24
smfa  25      size retpt(ps);         $ return label
smfa  26
smfa  27 .=zzyorg a     $ reset counter for return labels
smfa  28
smfa  29 .+mc size ctpc(ws);          $ little 'convert-to-primary-case'
smfa  30
smfa  31      size fold(1);           $ indicates whether case-folding should be
smfa  32      data fold = yes;        $  performed
      65
      66
      67      nameset nstrulex;
      68
      69          size card(.sds. cpc); $ current card image
      70          size card_pos(ps);  $ current position in card
      71          size card_len(ps);  $ index of last non-blank on card
      72
      73          size eor_seen(1);   $ end-of-record has occurred
      74          data eor_seen = no;
      75
      76          size tok(cs);  $ token being built
      77          dims tok(toklen_lim);
      78
      79          size tok_pos(ps),         $ current position in tok = token le
      80               tok_typ(ps);        $ lex_typ of token
      81
      82          size char(ps),    $ current character
      83               char1(ps);   $ extra character
      84
      85          size p(ps);   $ symtab pointer
      86
      87$ little string search set definitions:
      88
      89$ little uses the following pre-defined string search sets:
      90
      91      +*  ss_blank   =  001  **  $ blank
      92      +*  ss_separ   =  002  **  $ blank-equivalent separators
      93      +*  ss_digit   =  004  **  $ digits 0...9
      94      +*  ss_ucchar  =  008  **  $ upper case alphabetics a...z
      95      +*  ss_lcchar  =  016  **  $ lower case alphabetics a...z
      96      +*  ss_break   =  032  **  $ break character ('_')
      97
      98$ setl uses the following additional search classes:
      99
     100      +*  ss_delim   =  064  **  $ delimiter
     101      +*  ss_ddelim  =  128  **  $ double delimiter
     102      +*  ss_alter   =  512  **  $ 'altchar_tab'-defined characters
     103
     104$ groups of search classes:
     105
     106      +*  ss_alpha   =  024  **  $ alphabetic
     107      +*  ss_alpham  =  060  **  $ alphameric
     108
smfb  32$ for efficiency, we duplicate some of the little string functions as
smfb  33$ internal subroutines, to avoid repeated external subroutine calls.
smfb  34$ this implies that we need to dublicate the definition of the string
smfb  35$ search tables.
smfb  36
smfb  37          size sstab(ws);     $ string search table
smfb  38          dims sstab(cssz);
smfb  39
smfc  11 .+r36.   $ initialise sstab for s10/s20 (9 bit ascii)
smfb  41          data sstab =
smfb  42              0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
smfb  43              0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
smfb  44              ss_ucchar(26), 0(4), ss_break, 0, ss_lcchar(26), 0(5),
smfb  45              0(384);
smfc  12 ..r36
smfb  47 .+s32.   $ initialise sstab for s32 (8 bit ascii)
smfb  48          data sstab =
smfb  49              0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
smfb  50              0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
smfb  51              ss_ucchar(26), 0(4), ss_break, 0, ss_lcchar(26), 0(5),
smfb  52              0(128);
smfb  53 ..s32
smfb  54 .+s37.   $ initialise sstab for s37 (8 bit ebcdic)
smfb  55          data sstab =
smfb  56              0(5), ss_separ /* tab */, 0(6), ss_separ /* form feed */,
smfb  57              0(51), ss_blank ! ss_separ, 0(44), ss_break, 0(18), 0(1),
smfb  58              ss_lcchar(9), 0(7), ss_lcchar(9), 0(8), ss_lcchar(8),
smfb  59              0(22), 0, ss_ucchar(9), 0(7), ss_ucchar(9), 0(8),
smfb  60              ss_ucchar(8), 0(6), ss_digit(10), 0(6);
smfb  61 ..s37
smfb  62 .+s47.   $ initialise sstab for s47 (8 bit ascii)
smfb  63          data sstab =
smfb  64              0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
smfb  65              0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
smfb  66              ss_ucchar(26), 0(4), ss_break, 0, ss_lcchar(26), 0(5),
smfb  67              0(128);
smfb  68 ..s47
smfb  69 .+s66.   $ initialise sstab for s66
smfb  70          data sstab =
smfb  71              0,
smfb  72              ss_ucchar(26),  $ alphabetics
smfb  73              ss_digit(10),   $ numerics
smfb  74              0(8),
smfb  75              ss_blank ! ss_separ, $ blank (the only separator)
smfb  76              0(7),
smfb  77              ss_break,       $ break (underline)
smfb  78              0(10);          $ remaining characters
smfb  79 ..s66
suna  24 .+s68.   $ initialise sstab for mc68000 (8 bit ascii)
suna  25          data sstab =
suna  26              0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
suna  27              0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
suna  28              ss_ucchar(26), 0(4), ss_break, 0, ss_lcchar(26), 0(5),
suna  29              0(128);
suna  30 ..s68
smfb  80
smfb  81      +* anyc(c, sm)  =       $ look for character in string set
smfb  82          ((sm & sstab(1+c)) ^= 0)
smfb  83          **
smfb  84
     109$ macros for character types:
     110
     111      +*  alphabetic(c)  =  anyc(c, ss_alpha)   **
     112      +*  alphameric(c)  =  anyc(c, ss_alpham)  **
     113      +*  numeric(c)     =  anyc(c, ss_digit)   **
     114
     115      +* is_blank(c)  =
     116 .+mc     anyc(c, ss_separ)
     117 .-mc     (c = 1r )
     118          **
smfb  85
smfb  86$ define the table to map each character to the proper lexical case.
smfb  87
smfb  88          size lttab(ws);     $ lexical table
smfb  89          dims lttab(cssz);
smfb  90
smfb  91 .=zzyorg z
smfb  92
smfb  93          defc(lt_separ)      $ token separators
smfb  94          defc(lt_alpha)      $ alphabetic character
smfb  95          defc(lt_ddelim)     $ double-character delimiter
smfb  96          defc(lt_delim)      $ single-character delimiter
smfb  97          defc(lt_alter)      $ one-character alternate character
smfb  98          defc(lt_period)     $ the character '.'
smfb  99          defc(lt_quote)      $ the character -'-
smfb 100          defc(lt_digit)      $ numeric character
smfb 101          defc(lt_dollar)     $ the character '$'
smfb 102          defc(lt_error)      $ all remaining characters
     119
     120
     121$ delimitiers
     122$ -----------
     123
     124$ the table 'dsym_tab' maps single delimiters to their symbol table
     125$ entries.
     126
     127      +*  delims  =  '(),;:=+-*/#?'  **
     128
     129      size dsym_tab(ps);
     130      dims dsym_tab(.len. delims);
     131
     132$ 'ddelims(i,j)' is true for characters ij which form two character
     133$ delimiters.
     134
     135      +* double_delims_1 = '(/:/*:'  **
     136      +* double_delims_2 = '/)====*:'  **
     137
     138      +*  ddelim(i, j)  =  .f. i+1, 1, a_ddelim(j+1)  **
     139
smfb 103          size a_ddelim(cssz);
     141          dims a_ddelim(cssz);
     142
     143$ codes for ddelim
     144
     145$ the code for ddelim are zero origined.  this allows us to
     146$ initialize the entries for all chracacters which are not
     147$ double delimiters in a single data statement.
     148
     149 .=zzyorg z
     150
     151          defc0(dd_single)   $ single delimiter
     152          defc0(dd_double)   $ double delimiter
     153
     154          +*  dd_min  =  dd_single  **  $ minumum value
     155          +*  dd_max  =  dd_double  **  $ maximum value
     156
     157          data a_ddelim = dd_single(cssz);  $ set to default case
     158
     159      end nameset;
     160
     161
     162      size string(.sds. toklen_lim);  $ token in sds form
     163
     164      size j(ps);             $ loop index
     165      size org(ps);           $ origin for self-defining string
     166
     167      size trulex(ps);        $ pointer returned
     168      size hash(ps);          $ hashing function called
     169
smfb 104      size brkc(ws);          $ little string primitives
     172      size spns(ws);
     173
     174
     175/begin/        $ main entry point
     176
     177      if (eof_flag) return;
     178
     179      tok_pos = 0;  $ initialize length of token
     180
smfb 105      go to case(lttab(1+char)) in lt_separ to lt_error;
smfb 106
smfb 107/case(lt_separ)/              $ token separators
     182          $
     183          $ advance to the next non-blank character
     184          $
     185          if card_pos = 0 then
smfa  33              l_call(getc);
     187              if (is_blank(char) = no) go to begin;
     188          end if;
     189
     190          card_pos = card_pos + spns(card, card_pos, ss_separ) - 1;
smfa  34          l_call(getc);
     192
     193          go to begin;
     194
     195
smfb 108/case(lt_alpha)/              $ alphabetic character
     197          $
     198          $ <*name>
     199          $
     200          until alphameric(char) = no;
smfa  35              keepc; l_call(getc);
     202          end until;
     203
     204          tok_typ = l_name;
     205          go to esac;
     206
     207
smfb 109/case(lt_ddelim)/             $ double-character delimiter
     209          $
     210          $ this class includes characters such as '*' which may
     211          $ either stand alone or be part of a two character
     212          $ delimiter such as '**'.
     213          $
     214          $ we begin by saving char and getting the next character.
     215          $ next we lookup the two characters in 'ddelim' which
     216          $ gives us one of two cases:
     217          $
     218          $ 1. the first character is a delimiter and the second is
     219          $    part of the next token.
     220          $
     221          $ 2. the two characters form a double delimiter.
     222          $
smfa  36          char1 = char; l_call(getc);  $ save char, then get next char
     224
     225          go to c(ddelim(char1, char)) in dd_min to dd_max;
     226
     227          /c(dd_single)/      $ char1 is a single delimiter
     228
     229              trulex = dsym_tab(brkc(delims, 1, char1)+1);
     230              return;
     231
     232          /c(dd_double)/      $ double delimiter
     233
     234              tok(1) = char1;   tok(2) = char;   tok_pos = 2;
     235              tok_typ = l_delim;
     236
smfa  37              l_call(getc);  $ get character after delimiter
     238              go to esac;
     239
     240
smfb 110/case(lt_delim)/              $ single-character delimiter
     242          $
     243          $ look up the symbol table pointer and return
     244          $
     245          trulex = dsym_tab(brkc(delims, 1, char)+1);
smfa  38          l_call(getc);
     247          return;
     248
     249
smfb 111/case(lt_alter)/              $ one-character alternate character
     251          $
     252          $ one character alternative for setl symbol or literal
     253          $
     254          trulex = altchar_tab(brkc(altchars, 1, char)+1);
smfa  39          l_call(getc);
     256          return;
     257
     258
smfb 112/case(lt_period)/             $ the character '.'
     260          $
     261          $ <*bold>, <*real>, or <*dots>
     262          $
     263          $ if the period is followed by an alphabetic, it is part
     264          $ of a <*bold>;  if it is followed by a numeric, it is
     265          $ part of a <*real>;  otherwise it must be the start of
     266          $ a <*dots>.
     267          $
smfa  40          keepc;  l_call(getc);  $ read character after dot
     269
     270          if alphabetic(char) then $ start of <*bold>
     271              until alphameric(char) = no;
smfa  41                  keepc; l_call(getc);
     273              end until;
     274
     275              tok_typ = l_bold;
     276
     277          elseif numeric(char) then $ start of <*real>
     278              go to get_real;
     279
     280          elseif char = 1r. then  $ start of <*dots>
     281              until char ^= 1r.;
smfa  42                  keepc; l_call(getc);
     283              end until;
     284
     285              tok_typ = l_dots;
     286
     287          else                    $ invalid starting character
     288              call ermsg(14, 0);
     289              go to begin;
     290          end if;
     291
     292          go to esac;
     293
     294
smfb 113/case(lt_quote)/              $ the character -'-
     296          $
     297          $ <*string>
     298          $
     299          $ imbedded quotes are represented by a pair of quotes
     300          $ with no intervening blanks.  two string denotations
     301          $ separated by blanks are treated as a single denotation.
     302          $
     303          $ n.b. both the opening and closing quotes are considered
     304          $      part of the token.  this way the string -'x'-
     305          $      looks different from the identifier -x-.
     306          $
     307          $ strings are particularly likely to overflow the token
     308          $ buffer, for example if the closing quote is missing.
     309          $ for this reason we make an explicit test and jump out
     310          $ of the loop if necessary.
     311
     312          eor_seen = no;      $ initialise end-of-record flag
     313          keepc;   $ save quote
smfa  43          fold = no;          $ do not fold case while reading string
     314
     315          while 1;
smfa  44              l_call(getc);
     317
     318              if char = 1r' then  $ found quote
smfa  45                  fold = yes;  $ could be end of string
smfa  46                  l_call(getc);  $ read next character
     320
     321                  if char = 1r' then  $ double quote
     322                      keepc;
     323
     324                  elseif char = 1r  then  $ look for adjacent string
     325                      until is_blank(char) = no;
smfa  47                          l_call(getc); if (eof_flag) quit;
     327                          if (eor_flag) eor_seen = yes;
     328                      end until;
     329
     330                      if (char ^= 1r') quit;
     331                      if ( ^ eor_seen) quit;
     332                  else
     333                      quit;
     334                  end if;
smfa  48
smfa  49                  fold = no;  $ continue to read string
     335
     336              elseif eof_flag then  $ missing close quote
     337                  call eofr;
     338
     339              else   $ simple text
     340                  keepc;
     341              end if;
     342
     343              if tok_pos = toklen_lim - 1 then  $ too long
     344                  call ermsg(18, 0);
     345                  quit;
     346              end if;
     347
     348          end while;
smfa  50
smfa  51          fold = yes;  $ fold case while not reading string
     349
     350          $ insert final quote in token
     351          tok_pos = tok_pos + 1;
     352          tok(tok_pos) = 1r';
     353
     354          tok_typ = l_string;
     355          go to esac;
     356
     357
smfb 114/case(lt_digit)/              $ numeric character
     359          $
     360          $ <*int>, or <*real>
     361          $
     362          $ begin by collecting the integer part of the token.
     363          $ then see if the digits are followed by a decimal point.
     364          $
     365          until numeric(char) = no;
smfa  52              keepc; l_call(getc);
     367          end until;
     368          $
     369          $ if the digits are followed by a period, we may have
     370          $ either one token, namely a real denotation such as 1.0,
     371          $ or two tokens, such as in '1 .op'.  we can determine
     372          $ the proper alternative by inspecting the character
     373          $ after the period.
     374          $
     375          if char = 1r. then
smfa  53              keepc; l_call(getc);
     377
     378              if numeric(char) then  $ <*real> - get fraction
     379                  go to get_real;
     380              else            $ period is part of the next token
     381                  backc;
     382              end if;
     383          end if;
     384
     385          tok_typ = l_int;
     386          go to esac;
     387
     388
     389/get_real/
     390
     391          until numeric(char) = no;
smfa  54              keepc; l_call(getc);
     393          end until;
     394
     395          if char = 1re then  $ probably its an exponent
smfa  55              keepc; l_call(getc);
     397
     398              if char = 1r+ ! char = 1r- then  $ sign for exponent
smfa  56                  keepc; l_call(getc);
     400              end if;
     401
     402              if numeric(char) then  $ valid exponent
     403                  until numeric(char) = no;
smfa  57                      keepc; l_call(getc);
     405                  end until;
     406
     407              else  $ we had '1.0  else'
     408                  backc;
     409              end if;
     410
     411          end if;
     412
     413          tok_typ = l_real;
     414          go to esac;
     415
     416
smfb 115/case(lt_dollar)/             $ the character '$'
     418          $
     419          $ rest of line is comment
     420          $
smfa  58          call getcard;
     422          go to begin;
     423
     424
smfb 116/case(lt_error)/              $ all remaining characters
     426          $
     427          $ current character can not start a token
     428          $
     429          call ermsg(14, 0);
     430
smfa  59          l_call(getc);
     432          go to begin;
     433
     435
     436/esac/     $ hash in token
     437
     438$ we begin by converting the token to an sds. the sds must
     439$ be standard. i.e. each token xxx must have the same sorg
     440$ as a string xxx generated by the little compiler.
     441
     442      org = .sds. tok_pos + 1;  $ origin for string
     443
     444      string = 0;  $ initialize string
     445      slen string = tok_pos;
     446      sorg string = org;
     447
     448      do j = 1 to tok_pos;
     449          .f. org-j*cs, cs, string = tok(j);
     450      end do;
     451
     452      p = hash(string);
     453
     454$ if the token is a literal or keyword then its lex_type has
     455$ already been set; otherwise we set it to tok_typ.
     456
     457      if (key_val(p) = 0 & lit_val(p) = 0) lex_typ(p) = tok_typ;
     458
     459      trulex = p;
smfa  60
smfa  61      return;
smfa  62
smfa  63
smfa  64/getc/                        $ local subroutine to read next character
smfa  65
smfa  66$ this routine places the next character from the input stream into the
smfa  67$ global variable 'char'.  the global 'fold' indicates whether the
smfa  68$ character is to be translated to its primary case equivalent.
smfa  69
smfa  70      if card_pos >= scpc then  $ read next card
smfa  71          eor_flag = yes;  $ indicate end-of-record
smfa  72          call getcard;  $ read next card
smfa  73      else    $ advance in buffer
smfa  74          eor_flag = no;
smfa  75          card_pos = card_pos + 1;
smfa  76          char     = card_char(card_pos);
smfa  77
smfa  78 .+s66.
smfa  79$ if using 64 set and outside of quotes, convert percent to colon
smfb 117          if (fold .and. (char=3b'63'))  char = 1r:;
smfa  81 ..s66
smfa  82
smfa  83 .+mc     if (fold) char = ctpc(char);
smfa  84      end if;
smfa  85
smfa  86      go to rlab(retpt) in 1 to zzya;  $ return from local subroutine
     460
     461
     462      end fnct trulex;
       1 .=member initlex
       2      subr initlex;
       3
       4$ this routine initializes various tables used by trulex.
       5
       6
       7      size j(ps);             $ loop index
       8      size p(ps);             $ symbol table pointer
       9      size str(.sds. 1);      $ used to initialize delimiters
      10      size c(cs);             $ character code
      11      size c1(cs), c2(cs);    $ pair of characters
      12
      13      access nstrulex;
      14
      15      size hashlit(ps);       $ hashing function
      16      size brkc(ws);          $ little break string primitive
      17
      18
      19      $ initialise the input line to a blank line
      20      card = ' ' .pad. cpc; sorg card = card_org; slen card = wpc * cpw;
      21      card_pos = 0;
      22      char = 1r ;
      23
      24      $ initialize delimiters, finding their hash, and setting
      25      $ their class.  we will revise the class for double
      26      $ delimiters later.
      27
      28      call blds(delims, ss_delim);
      29
      30      str = ' ';
      31
      32      do j = 1 to .len. delims;
      33          c = .ch. j, delims;   .ch. 1, str = c;
smfb 118          sstab(1+c) = sstab(1+c) ! ss_delim;  $ define pattern set
      34
      35          p = hashlit(str);
      36          dsym_tab(brkc(delims, 1, c)+1) = p;
      37      end do;
      38
      39      $ process double delimiters
      40      $
      41      $ n.b. 'ddelim' has already been initialized by a data state-
      42      $      ment so that all invalid pairs indicate dd_single.
      43
      44      call blds(double_delims_1, ss_ddelim);
      45
      46      do j = 1 to .len. double_delims_1;
      47          c1 = .ch. j, double_delims_1;
      48          c2 = .ch. j, double_delims_2;
      49          ddelim(c1, c2) = dd_double;
smfb 119
smfb 120          sstab(1+c1) = sstab(1+c1) ! ss_ddelim;  $ define pattern set
      50      end do;
      51
      52      $ initialize alternate characters
      53
      54      .len. altchars = 0;
      55
      56 .+s10.
      57      if char_set = cset_ext then
      58          call altchar('<<',     3b'173');  $ left set brace
      59          call altchar('>>',     3b'175');  $ right set brace
      60          call altchar('(/',     3b'133');  $ left square bracket
      61          call altchar('/)',     3b'135');  $ right square bracket
      62          call altchar('st',     3b'174');  $ vertical bar
      63          call altchar('st',     3b'041');  $ exclamation mark
      64      end if;
      65 ..s10
      66
      67 .+s20.
      68      if char_set = cset_ext then
      69          call altchar('<<',     3b'173');  $ left set brace
      70          call altchar('>>',     3b'175');  $ right set brace
      71          call altchar('(/',     3b'133');  $ left square bracket
      72          call altchar('/)',     3b'135');  $ right square bracket
      73          call altchar('st',     3b'174');  $ vertical bar
      74          call altchar('st',     3b'041');  $ exclamation mark
      75      end if;
      76 ..s20
      77
      78
      79 .+s32.
      80      if char_set = cset_ext then
      81          call altchar('<<',     4b'7b');   $ left set brace
      82          call altchar('>>',     4b'7d');   $ right set brace
      83          call altchar('(/',     4b'5b');   $ left square bracket
      84          call altchar('/)',     4b'5d');   $ right square bracket
      85          call altchar('st',     4b'7c');   $ vertical bar
      86          call altchar('st',     4b'21');   $ exclamation mark
      87      end if;
      88 ..s32
      89
      90 .+s37.
      91      if char_set = cset_ext then
      92          call altchar('<<',     4b'8b');   $ left set brace
      93          call altchar('>>',     4b'9b');   $ right set brace
      94          call altchar('(/',     4b'ad');   $ left square bracket
      95          call altchar('/)',     4b'bd');   $ right square bracket
      96          call altchar('st',     4b'4f');   $ vertical bar
      97          call altchar('st',     4b'5a');   $ exclamation mark
asca  15
asca  16 .+ascebc.
asca  17$ cset_por for s37 reflects tn chain conventions;  cset_asc reflects
asca  18$ the (cdc-based) ascii to ebcdic translation tables used at nyu.
asca  19$ use cset_asc for files originally written in ascii which are to
asca  20$ be compiled under ebcdic using the translation used by nyu tape
asca  21$ driver.
asca  22      elseif char_set = cset_asc then
asca  23          call altchar('<<',     4b'c0');   $ left set brace
asca  24          call altchar('>>',     4b'd0');   $ right set brace
asca  25          call altchar('(/',     4b'4a');   $ left square bracket
asca  26          call altchar('/)',     4b'5a');   $ right square bracket
asca  27          call altchar('st',     4b'6a');   $ vertical bar
asca  28          call altchar('st',     4b'4f');   $ exclamation mark
asca  29 ..ascebc
      98      end if;
      99 ..s37
     100
     101 .+s47.
     102      if char_set = cset_ext then
     103          call altchar('<<',     4b'7b');   $ left set brace
     104          call altchar('>>',     4b'7d');   $ right set brace
     105          call altchar('(/',     4b'5b');   $ left square bracket
     106          call altchar('/)',     4b'5d');   $ right square bracket
     107          call altchar('st',     4b'7c');   $ vertical bar
     108          call altchar('st',     4b'21');   $ exclamation mark
     109      end if;
     110 ..s47
     111
     112 .+s66.
     113      if char_set = cset_ext then
     114          call altchar('<<',     3b'74');   $ at sign
     115          call altchar('>>',     3b'75');   $ reverse slant
     116          call altchar('(/',     3b'61');   $ left square bracket
     117          call altchar('/)',     3b'62');   $ right square bracket
     118          call altchar('st',     3b'67');   $ ampersand
     119      end if;
     120 ..s66
suna  31
suna  32 .+s68.
suna  33      if char_set = cset_ext then
suna  34          call altchar('<<',     4b'7b');   $ left set brace
suna  35          call altchar('>>',     4b'7d');   $ right set brace
suna  36          call altchar('(/',     4b'5b');   $ left tuple bracket
suna  37          call altchar('/)',     4b'5d');   $ right tuple bracket
suna  38          call altchar('st',     4b'7c');   $ vertical bar
suna  39          call altchar('st',     4b'21');   $ exclamation mark
suna  40      end if;
suna  41 ..s68
     121
     122      call blds(altchars, ss_alter);
smfb 121
smfb 122      do j = 1 to .len. altchars;
smfb 123          c = .ch. j, altchars;
smfb 124          sstab(1+c) = sstab(1+c) ! ss_alter;  $ define pattern set
smfb 125      end do;
smfb 126
smfb 127      do c = 0 to cssz-1;
smfb 128          if is_blank(c)        then lttab(1+c) = lt_separ;  cont; end;
smfb 129          if alphabetic(c)      then lttab(1+c) = lt_alpha;  cont; end;
smfb 130          if anyc(c, ss_ddelim) then lttab(1+c) = lt_ddelim; cont; end;
smfb 131          if anyc(c, ss_delim)  then lttab(1+c) = lt_delim;  cont; end;
smfb 132          if anyc(c, ss_alter)  then lttab(1+c) = lt_alter;  cont; end;
smfb 133          if c = 1r.            then lttab(1+c) = lt_period; cont; end;
smfb 134          if c = 1r'            then lttab(1+c) = lt_quote;  cont; end;
smfb 135          if numeric(c)         then lttab(1+c) = lt_digit;  cont; end;
smfb 136          if c = 1r$            then lttab(1+c) = lt_dollar; cont; end;
smfb 137          lttab(1+c) = lt_error;
smfb 138      end do;
smfb 139
smfb 140
smfb 141      macdrop(anyc);
smfb 142
smfb 143      macdrop4(lt_separ, lt_alpha, lt_ddelim, lt_delim)
smfb 144      macdrop4(lt_alter, lt_period, lt_quote, lt_digit)
smfb 145      macdrop2(lt_dollar, lt_error)
     123
     124
     125      end subr initlex;
       1 .=member altch
       2      subr altchar(s, c);
       3
       4$ this routine initializes the character 'c' as an alternate to the
       5$ string 's'.
       6
       7
       8      size s(.sds. 72);       $ string representing token
       9      size c(cs);             $ one character alternate for 's'
      10
      11      size hashlit(ps);       $ hashing function called
      12
      13
      14      .len. altchars = (.len. altchars) + 1;
      15      .ch. (.len. altchars), altchars = c;
      16
      17      altchar_tab(.len. altchars) = hashlit(s);
      18
      19
      20      end subr altchar;
       1 .=member getcard
       2      subr getcard;
       3
       4$ this routine reads the next card image and sets 'char' to the first
       5$ character. it also looks for title, eject, and include cards.
       6
       7$ the card image is read by the little library routine 'getinc' which
       8$ returns an array in r(cpw) format. we begin by converting it to
       9$ a self defining string
      10
      11$ card images are added to the listing file after they have been
      12$ parsed. this way the card image for 'proc p' can be used as a
      13$ title before it appears in the text.
      14
      15
      16      size ara(ws);   $ array read by getinc
      17      dims ara(wpc);
      18
      19      size j(ps),  $ loop index
      20           tab_str(.sds. 1),      $ tab character
      21           init_col(ps),          $ initial column for title
      22           p1(ps),  $ pointer to start of title
      23           p2(ps);  $ pointer to end of title
      24
      25      size str(.sds. cpc),   $ string containing 'list', etc.
      26           title(.sds. cpc); $ new listing title
      27      size anyc(ws);          $ little string primitive
      28
      29      access nstrulex;
      30
      31
      32      call put_card;          $ print previous card
      33
      34/loop/  $ process listing directives
      35
      36      call getinc(ara, 1, wpc, eof_flag);
      37      line_no = line_no + 1;
      38
      39      if eof_flag then  $ set 'card' to blanks and return
      40          card = ' ' .pad. cpc;
      41          return;
      42      end if;
      43
      44      do j = 1 to wpc;
      45          .f. card_org - j*ws, ws, card = ara(j);
      46      end do;
      47
      48      sorg card = card_org;
      49      slen card = wpc * cpw;
      50
      51$ look for '.' in column 2. if we find one look for the next blank
      52$ and find the string between the dot and the blank.
      53
      54      if card_char(2) = 1r. then
      55
      56          do j = 3 to cpc;
      57 .+mc         if (anyc(card_char(j), 2)) quit do;
      58 .+mc         $ anyc(..., 2) matches blank-equivalent separators
      59 .-mc         if (card_char(j) = 1r )    quit do;
      60          end do;
      61
      62          str = .s. 3, j-3, card;
      63 .+mc     call stpc(str);     $ convert to primary case
      64
      65          if str .seq. 'list' then  $ turn on listing
      66              list_flag = yes;
      67              go to loop;
      68
      69          elseif str .seq. 'nolist' then  $ turn off listing
      70              list_flag = no;
      71              go to loop;
      72
      73          elseif str .seq. 'eject' then  $ page eject
      74              if (list_flag) put, page;
      75              go to loop;
      76
      77          elseif str .seq. 'title' then  $ change title
      78
      79$ the title is surrounded by quotes. find it.
      80              p1 = '''' .in. card;
      81              if (p1 = 0) p1 = 1;
      82              card_char(p1) = 1r ;
      83
      84              p2 = '''' .in. card;
      85              if (p2 = 0) p2 = scpc;
      86              title = .s. p1+1, p2-p1-1, card;
      87
      88$ call little library to set title
      89              if cc_tab = 1r then
      90                  call etitlr(yes, '', 9, cpc+1);
      91                  call etitlr(yes, ' ', 5, 1);
      92              else
      93                  tab_str = ' ';
      94                  .ch. 1, tab_str = cc_tab;
      95                  call etitlr(yes, tab_str, 9, cpc);
      96                  call etitlr(yes, ' ', 5, 1);
      97              end if;
      98
      99              if seqf_flag then
     100                  init_col = 10;
     101              else
     102                  init_col = 2;
     103              end if;
     104
     105              call etitlr(yes, title, init_col, 0);
     106              if (list_flag) put, page;
     107
     108              go to loop;
     109          end if;
     110      end if;
     111
     112      is_listed  = no;        $ line has not been listed
     113      is_written = no;        $ line has not been written for optimiser
     114
     115      card_pos = 0;
     116      char     = 1r ;  $ nominal blank at end of line
     117
     118
     119      end subr getcard;
       1 .=member putcard
       2      subr put_card;
       3
       4$ this routine prints the current card image.
       5
       6      size j(ps);             $ loop index
       7      size temp1(ws);         $ temporaries for line/statement numbers
       8      size temp2(ws);
       9
      10      size anyc(ws);          $ little seek-character string primitive
      11      size rsps(ws);          $ little right-span string-set string prim
      12
      13      access nstrulex;
      14
      15 .+sq1.
      16      if ((slen ssm_title) ^= 0) & ^ is_written then
      17          $ (logically) 'delete' trailink blanks
      18          card_len = slen card;
      19          if is_blank((.ch. card_len, card)) then
      20              card_len = card_len - rsps(card, card_len, ss_separ);
      21          end if;
      22
      23          $ copy the line for the optimiser
      24          putbhdr(bt_string, card_len);
      25
      26          do j = 1 to (card_len + cpw - 1) / cpw;
      27              putbdat((.f. (sorg card)-j*ws, ws, card))
      28          end do;
      29
      30          is_written = yes;   $ line has been copied
      31      end if;
      32 ..sq1
      33      if (is_listed ! ^ list_flag) return;
      34
      35      is_listed = yes;
      36
      37      go to prcase(seqf_flag) in 0 to 3;
      38
      39/prcase(1)/                        $ line number only
      40
      41          put :line_no ,i(7);
      42          go to print_tab;
      43
      44
      45/prcase(2)/                        $ statement number only
      46
      47          put :stmt_count ,i(7);
      48          go to print_tab;
      49
      50
      51/prcase(3)/                        $ 3 digits of each
      52
      53          temp1 = mod(line_no,1000);
      54          if (temp1 = 0) call setdig(1, line_no/1000, 2, yes);
      55
      56          temp2 = mod(stmt_count, 1000);
      57          if (temp1 = 0)       call setdig(1, stmt_count/1000, 6, yes);
      58          if (stmt_count < 10) call etitlr(1, '   ', 6, 3);
      59
      60          put :temp1 ,i(3) ,x(1) :temp2 ,i(3);
      61
      62
      63/print_tab/
      64
      65
      66$ if a tab character is available, print it so that the following
      67$ will be aligned properly.
      68
      69      if cc_tab ^= 1r  then
      70          put: cc_tab, r(1);
      71      else
      72          put, column(9);
      73      end if;
      74
      75/prcase(0)/
      76
      77      put: (.s. 1, scpc, card), a;
      78
      79      if ( (.s. scpc+1, cpc-scpc, card)
      80          .sne. (' ' .pad.  cpc-scpc)) then
      81          put, ' . ': (.s. scpc+1, cpc-scpc, card), a;
      82      end if;
      83
      84      if m_flag then
      85          if cc_tab ^= 1r  then
      86              put, column(16+cpc);
      87          else
      88              put, column(11+cpc);
      89          end if;
      90
      91          put :cstmt_count ,i;
      92      end if;
      93
      94      put, skip;
      95
      96
      97      end subr put_card;
       1 .=member setdig
       2      subr setdig(p1, numb, from, blank_zer);
       3
       4      size p1(ps),
       5           numb(ws),
       6           from(ps),
       7           blank_zer(1);
       8
       9      size temp(.sds. 3),
      10           i(ps),
      11           num(ws),
      12           leng(ps);
      13
      14      temp = '   '; leng = 3;
      15
      16      num = numb;
      17
      18      do i = 3 to 1 by -1;
      19          if ( (num > 0) .or. ^ blank_zer) .ch. i, temp = mod(num,10)
      20                                                           + 1r0;
      21          num = num / 10;
      22      end do;
      23
      24      call etitlr(p1, temp, from, leng);
      25
      26      end subr setdig;
       1 .=member atitle
       2      subr atitle;
       3
       4$ this routine performs automatic titling.
       5
       6      access nstrulex;
       7
       8      size j(ps),  $ loop index
       9           tab_str(.sds. 1),  $ tab character
      10           init_col(ps),      $ starting column for heading
      11           len(ps);  $ length of title
      12
      13      if at_flag then
      14
      15$ find first non blank then character
      16          j = 1;
      17
      18          while 1;
      19              if (j > cpc) quit;
      20              if (.ch. j, card ^= 1r ) quit;
      21
      22              j = j + 1;
      23          end while;
      24
      25          len = scpc-j+1;
      26
      27          if cc_tab = 1r then
      28              call etitlr(yes,  '', 9, cpc+1);
      29              call etitlr(yes, ' ', 5, 1);
      30          else
      31              tab_str = ' ';
      32              .ch. 1, tab_str = cc_tab;
      33              call etitlr(yes, tab_str, 9, cpc);
      34              call etitlr(yes, ' ', 5, 1);
      35          end if;
      36
      37          if (seqf_flag) then
      38              init_col = 10;
      39          else
      40              init_col = 2;
      41          end if;
      42
      43          call etitlr(yes, (.s. j, len, card), init_col, len);
      44          put, page;
      45      end if;
      46
      47
      48      end subr atitle;
       1 .=member tokover
       2      subr tok_over;
       3
       4$ this routine is called when a token exceeds the maximum token length.
       5$ we print an error message and then reset tok_pos so that only the
       6$ second half of the token will be saved.
       7
       8      access nstrulex;
       9
      10      call ermsg(18, 0);
      11      tok_pos = 0;
      12
      13
      14      end subr tok_over;
       1 .=member bldgen
       2      fnct bldgen(n, first);
       3
       4$ this routine builds a token for a generated macro argument.
       5$ we allow each macro to have up to 26 generated arguments.
       6
       7$ we generate a token of the form
       8
       9$    gax.yyyyy
      10
      11$ where x is the n-th letter of the alphabet and yyyyy is the number of
      12$ macro expansions which have contained a token starting with 'gax'.
      13
      14$ first is true if this is the first token 'gax' we are generating
      15$ for this macro expansion. if first is true, we increment the
      16$ counter yyyyy.
      17
      18
      19      size n(ps),     $ number of generated argument
      20           first(1);  $ on for first occurrence of argument
      21
      22      size nn(ps),  $ local copy of n.
      23           j(ps),  $ loop index
      24           str(.sds. 9); $ string for token
      25
      26      size count(ps); $ array of counters yyyyy
      27      dims count(param_lim);
      28      data count = 0(param_lim);
      29
      30      +*  count_lim = 99999  ** $ maximum value for yyyyy
      31
      32
      33      size bldgen(ps),  $ value returned
      34           hash(ps);   $ hashing function
      35
      36
      37      if first then
      38          countup(count(n), count_lim, 'generated arguments');
      39      end if;
      40
      41      str = 'ga .     ';  $ initialize string
      42      .ch. 3, str = .ch. n, 'abcdefghijklmnopqrstuvwxyz';
      43
      44      nn = count(n);  $ copy counter for conversion to string
      45
      46      do j = 9 to 5 by -1;
      47          .ch. j, str = charofdig(mod(nn, 10));
      48          nn = nn/10;
      49      end do;
      50
      51      bldgen = hash(str);
      52      lex_typ(bldgen) = l_name;
      53
      54
      55      end fnct bldgen;
       1 .=member bugact
       2      subr bugact;
       3
       4$ this routine processes compiler debugging options.
       5
       6
       7      access parsens;
       8
       9
      10      if dbg_min<=key_val(parse_tok) & key_val(parse_tok)<=dbg_max then
      11
      12          go to case(key_val(parse_tok)) in dbg_min to dbg_max;
      13
      14
      15/case(dbg_ptrm0)/             $ turn macro processor trace off
      16              mt_flag = no;   go to esac;
      17
      18/case(dbg_ptrm1)/             $ turn macro processor trace on
      19              mt_flag = yes;  go to esac;
      20
      21/case(dbg_ptrp0)/             $ turn parse trace off
      22              pt_flag = no;   go to esac;
      23
      24/case(dbg_ptrp1)/             $ turn parse trace on
      25              pt_flag = yes;  go to esac;
      26
      27/case(dbg_ptrt0)/             $ turn token trace off
      28              tt_flag = no;   go to esac;
      29
      30/case(dbg_ptrt1)/             $ turn token trace on
      31              tt_flag = yes;  go to esac;
      32
      33/case(dbg_prsod)/             $ dump open-tokens
      34              call odump;     go to esac;
      35
      36/case(dbg_prspd)/             $ dump polish and xpolish strings
      37              call pdump;     go to esac;
      38
      39/case(dbg_prssd)/             $ dump parser dbgbol table
      40              call sdump;     go to esac;
      41
      42
      43/esac/
      44
      45
      46      end if;
      47
      48
      49      end subr bugact;
       1 .=member hash
       2      fnct hash(string);
       3
       4$ this routine hashes a token into symtab and returns a pointer to
       5$ it.
       6
       7$ self defining strings generally contain a few unused bits
       8$ whose value is undefined. 'hash' assumes that these bits
       9$ are all zero. this is true for strings produced by 'trulex',
      10$ but not for strings produced by '.s.', etc.
      11
      12$ strings whose extra bits are not guarenteed zero should
      13$ be hashed by calling 'hashlit'.
      14
      15
      16      size string(sds_sz);   $ token to be hashed
      17
      18      size hash(ps);   $ symtab pointer returned
      19
      20      size indx(ps),  $ index into hash headers
      21           len(ps),  $ slen of string
      22           org(ps),  $ sorg of string
      23           words(ps),  $ no. of words in new names entry
      24           nam(ps),  $ pointer to names
      25           hashc(ws),  $ hash code of token
      26           word(ws),   $ current word of token
      27           head(ps),  $ pointer to hash header
      28           j(ps);      $ loop index
      29
      30
      31$ we begin by making a names entry for the new token. we do this
      32$ now since it is easier to compare two names entries than a names
      33$ entry and a string. we do not adjust 'namesp' until we build
      34$ a new symtab entry.
      35
      36$ as we make the names entry, we compute the hash code as the
      37$ exclusive-or of all its words.
      38
      39      len = slen string;  $ length of token
      40      org = sorg string;  $ origin of token
      41
      42      words = org/ws;  $ number of words needed
      43      if (namesp + words > names_lim) call overfl('names');
      44
      45      hashc = 0;  $ hash code
      46
      47      do j = 1 to words;
      48          word = .f. 1 + (j-1)*ws, ws, string;
      49
      50          hashc = hashc .ex. word;
      51          names(namesp+j) = word;
      52      end do;
      53
      54      hashc = (.f. 1, ws/2, hashc) .ex. (.f. ws/2+1, ws/2, hashc);
      55
      56$ get a pointer into heads, and search the clash list.
      57      indx = mod(hashc, heads_lim) + 1;
      58      hash = heads(indx);
      59
      60      while hash ^= 0;
      61
      62          nam = name(hash);
      63
      64          do j = 1 to words;
      65              if (names(nam-1+j) ^= names(namesp+j)) go to nxt;
      66          end do;
      67
      68          return;
      69
      70      /nxt/
      71          hash = link(hash);
      72      end while;
      73
      74$ no match. get free symtab entry
      75      countup(symtabp, symtab_lim, 'symtab');
      76      hash = symtabp;
      77
      78$ fill in symtab entry
      79      symtab(hash) = 0;
      80      name(hash) = namesp + 1;
      81      namesp = namesp + words;
      82
      83$ add to front of clash list
      84      link(hash) = heads(indx);
      85      heads(indx) = hash;
      86
      87
      88      end fnct hash;
       1 .=member hashlit
       2      fnct hashlit(str1);
       3
       4$ this is a special hashing routine for processing literals.
       5$ it hashes strings which are not necessarily in the format
       6$ required by 'hash'. it also converts bold names to names
       7$ if we are not in the prefix stropping mode.
       8
       9
      10      size str1(.sds. 30);  $ original string
      11
      12      size hashlit(ps);   $ pointer returned
      13
      14      size str2(.sds. 30),  $ new string built
      15           p1(ps),   $ position in str1
      16           p2(ps),   $ position in str2
      17           j(ps),  $ loop index
      18           len(ps);  $ length of strings
      19
      20      size hash(ps);  $ hashing function
      21
      22
      23      p1 = 1;   $ initialize
      24      p2 = 1;
      25
      26      len = slen str1;
      27
      28      str2 = 0;
      29
      30      sorg str2 = .sds. len+1;
      31      slen str2 = len;
      32
      33      do j = 0 to len-1;
      34          .ch. p2+j, str2 = .ch. p1+j, str1;
      35      end do;
      36
      37      hashlit = hash(str2);
      38
      39
      40      end fnct hashlit;
       1 .=member stat1
       2      subr stat1;
       3
       4$ this routine resets the statement counter to 1.
       5
       6      cstmt_count = cstmt_count + 1;
       7      ustmt_count = cstmt_count;
       8      estmt_count = 0;
       9 .+sq1.
      10      if (slen ssm_title) then
      11          if cstmt_count = 1 then
      12              putbhdr(bt_map, 0)
      13          else
      14              putbhdr(bt_tuple, 1)
      15              putbhdr(bt_tuple, 1)
      16          end if;
      17
      18          putbhdr(bt_tuple, 0)
      19          putbhdr(bt_int, 1)   putbdat(cstmt_count)
      20          putbhdr(bt_tuple, 0)
      21      end if;
      22 ..sq1
      23
      24
      25      end subr stat1;
       1 .=member newstat
       2      subr new_stat;
       3
       4$ this routine is called at the start of each statement.
       5
       6      cstmt_count = cstmt_count + 1;
       7 .+sq1.
smfc  13$ assert 0 <= cstmt_count < li_dbas as defined in compl.lipkg.
       8      if (slen ssm_title) then
       9          if cstmt_count = 1 then
      10              put ,skip;            $ emit blank line
      11              call contlpr(27, yes);$ echo to the terminal
      12              put ,'*** setl compiler error (code po1) ***' ,skip;
      13              call contlpr(27, no); $ stop to echo to the terminal
      14              call ltlfin(1, 0);    $ abnormally terminate
      15          end if;
      16
      17          putbhdr(bt_tuple, 1)
      18          putbhdr(bt_tuple, 1)
      19
      20          putbhdr(bt_tuple, 0)
      21          putbhdr(bt_int, 1)   putbdat(cstmt_count)
      22          putbhdr(bt_tuple, 0)
      23      end if;
      24 ..sq1
      25
      26
      27      end subr new_stat;
       1 .=member back
       2      subr back(i, j);
       3
       4$ this routine backs up the scanner by i tokens and the polish string
       5$ by j nodes.
       6
       7$ i and j are both in the range 0-1.
       8
       9
      10      size i(ps),
      11           j(ps);
      12
      13      access backup;
      14
      15
      16      tok_out = tok_out - i;
      17      if (tok_out = 0) tok_out = tok_lim;
      18
      19      polp = polp - j;
      20
      21
      22      end subr back;
       1 .=member backx
       2      subr backx;
       3
       4$ this routine backs up the auxiliary string one node.
       5
       6      xpolp = xpolp - 1;
       7
       8
       9      end subr backx;
       1 .=member copyx
       2      subr copyx;
       3
       4$ this routine copies the last node on the polish string file onto
       5$ the auxiliary file.
       6
       7      if (xpolp = xpol_lim) call putxtab;
       8      xpolp = xpolp + 1;
       9
      10      xpolish(xpolp) = polish(polp);
      11
      12
      13      end subr copyx;
       1 .=member mx
       2      subr mx(node);
       3
       4$ this routine writes a marker onto the auxiliary string.
       5
       6      size node(ps);  $ marker p_xxx
       7
       8      putxp(node, pol_mark);
       9
      10
      11      end subr mx;
       1 .=member stackexp
       2      subr stackexp;
       3
       4$ this is the first of three routine which make up an operator precedenc
       5$ parser for expressions.
       6
       7$ the precedence parser does not handle all expressions, but rather thos
       8$ expressions made up of binary and unary operators.
       9
      10$ when the top down parser recognizes operators and operands it immed-
      11$ iately writes them onto the polish string. each time it recognizes an
      12$ operator it calls the precedence parser which removes the operator
      13$ from the string, places it on a stack, and replaces it with any
      14$ previous operators which have higher precedence.
      15
      16$ since expressions can be nested, we must have some way of delimiting
      17$ the stack entries associated with each expression. we do this by
      18$ calling 'stackexp' at the start of each expression. we push a zero
      19$ word onto the stack. this has the effect both of separating the
      20$ entries for different expressions and of pushing an entry of
      21$ minimal precedence on the stack.
      22
      23$ the precedence stack is called 'ostack' and has three fields:
      24
      25$ oname:      names pointer for operator
      26$ omark:      a marker, one of p_bin, p_ubin, p_un, p_uun.
      27$ oprec:      the precedence.
      28
      29$ the marker node is emitted after the operator itself.
      30
      31$ the variable 'ostackp' points to the last entry in ostack.
      32
      33
      34      nameset ostack;
      35
      36      +*  ostack_lim  =  20  **
      37
suna  42          +* ostack_sz  =
suna  43 .+r32        64
suna  44 .+r36        32
suna  45 .+s66        32
suna  46              **
      41
      42          size ostack(ostack_sz);
      43          dims ostack(ostack_lim);
      44
      45          size ostackp(ps);
      46          data ostackp = 0;
      47
suna  47 .+r32.
suna  48          +*  oname(i)  =  .f. 01, 32, ostack(i)  **
suna  49          +*  omark(i)  =  .f. 33, 08, ostack(i)  **
suna  50          +*  oprec(i)  =  .f. 41, 08, ostack(i)  **
suna  51 ..r32
suna  52 .+r36.
suna  53          +*  oname(i)  =  .f. 01, 16, ostack(i)  **
suna  54          +*  omark(i)  =  .f. 17, 08, ostack(i)  **
suna  55          +*  oprec(i)  =  .f. 25, 08, ostack(i)  **
suna  56 ..r36
suna  57 .+s66.
suna  58          +*  oname(i)  =  .f. 01, 16, ostack(i)  **
suna  59          +*  omark(i)  =  .f. 17, 08, ostack(i)  **
suna  60          +*  oprec(i)  =  .f. 25, 08, ostack(i)  **
suna  61 ..s66
      62
      63      end nameset;
      64
      65
      66      countup(ostackp, ostack_lim, 'ostack');
      67      ostack(ostackp) = 0;
      68
      69
      70      end subr stackexp;
       1 .=member opprec
       2      subr opprec(m);
       3
       4$ this routine processes binary and unary operators used in expressions.
       5$
       6$ when it is called, the parser has examined the next token to see
       7$ whether the operator is the prefix of an on-the-fly assignment or
       8$ a compound operator.  therefore the binary operator we are interested
       9$ is the current last token in the token buffer, which may or may not be
      10$ identical to parse_tok.  rather than backing up the scanner and polish
      11$ to re-parse the operator (once we found it not to be part of a more
      12$ complex form) in order to reset parse_tok, we access tok_buff directly
      13$
      14$ 'm' is a marker node associated with the operator. by examining
      15$ m, we can tell whether the operator is binary, unary, etc.
      16
      17$ if the operator is unary, we simply make a new ostack entry.
      18
      19$ if the operator is binary, we must first emit all previous
      20$ operators whose precedence with greater or equal precedence.
      21$ after this we push the new operator.
      22
      23$ note that as we pop the stack, we never check whether it is
      24$ empty. this is unnecessary since stackexp always makes an
      25$ ostack entry with zero precedence. when we reach this
      26$ entry, we will always quit the loop.
      27
      28
      29      size m(ps);  $ marker node
      30
      31      size nam(ps),   $ name of operator
      32           prec(ps),  $ its precedence
      33           bin(1);    $ flags binary operator
      34
      35      access ostack;
      36      access parsens;
      37      access backup;
      38
      39
      40      parse_tok = tok_buff(tok_out);
      41      polp = polp - 1;
      42      nam  = name(parse_tok);
      43
      44$ find precedence and set 'bin' to flag binary operators.
      45
      46      if m = p_bin then   $ system binary
      47          prec = key_val(parse_tok);
      48          bin  = yes;
      49
      50      elseif m = p_un then $ system unary
      51          prec = key_val(parse_tok);
      52          if (lex_typ(parse_tok) = l_unbin) prec = prec_un;
      53
      54          bin  = no;
      55
      56      elseif m = p_ubin then  $ user-defined binary
      57          prec = prec_ubin;
      58          bin  = yes;
      59
      60      else     $ user unary
      61          prec = prec_un;
      62          bin  = no;
      63      end if;
      64
      65$ if this is a binary operator, pop all previous operators with
      66$ greater or equal precedence.
      67      if bin then
      68          while oprec(ostackp) >= prec;
      69              putp(oname(ostackp), pol_name);  $ write name
      70              putp(omark(ostackp), pol_mark);  $ write marker
      71
      72              ostackp = ostackp-1;  $ pop stack
      73          end while;
      74      end if;
      75
      76$ push new operator.
      77      countup(ostackp, ostack_lim, 'ostack');
      78      oname(ostackp) = nam;
      79      omark(ostackp) = m;
      80      oprec(ostackp) = prec;
      81
      82
      83      end subr opprec;
       1 .=member popop
       2      subr popop;
       3
       4$ this routine is called after we have seen a user defined niladic
       5$ operator. when we first parsed the operator, we assumed it was
       6$ unary, and pushed it onto ostack. we now pop it, and write it
       7$ onto the polish string.
       8
       9
      10      access ostack;
      11
      12
      13      putp(oname(ostackp), pol_name);
      14
      15      ostackp = ostackp - 1;
      16
      17
      18      end subr popop;
       1 .=member popop1
       2      subr popop1;
       3
       4$ this routine is like popop, but simply throws away the top
       5$ ostack entry.
       6
       7
       8      access ostack;
       9
      10
      11      ostackp = ostackp - 1;
      12
      13
      14      end subr popop1;
       1 .=member popexp
       2      subr popexp;
       3
       4$ this routine is called at the end of each expression. we pop
       5$ and emit all the remaining operators in the expression, then
       6$ pop the zero word left by 'stackexp'.
       7
       8
       9      access ostack;
      10
      11
      12      while ostack(ostackp) ^= 0;
      13          putp(oname(ostackp), pol_name);  $ write name
      14          putp(omark(ostackp), pol_mark);  $ write marker
      15
      16          ostackp = ostackp - 1;  $ pop stack
      17      end while;
      18
      19      ostackp = ostackp - 1;  $ pop zero word
      20
      21
      22      end subr popexp;
       1 .=member opentoks
       2      subr opentoks(iter, skip);
       3
       4$ this routine is called at the start of each control statement.
       5$ it collects information which is necessary to process 'end',
       6$ 'quit', and 'cont' statements.
       7
       8$ 1. a counter 'open_count' giving the number of control
       9$    statements which are currently open.
      10
      11$ 2. a bit vector 'is_iter' which indicates which control
      12$    statements are iterators. this bit vector is indexed
      13$    by values of open_count.
      14
      15$ 3. an array 'opntoks' containing the first few tokens
      16$    of each control statement.
      17
      18$ at this point we increment open_count, set is_iter, and
      19$ collect tokens in opntoks. we collect tokens by calling
      20$ gettok. when we are done we restore the token buffer to
      21$ its original status so that the tokens we have saved will
      22$ be passed onto the parser.
      23
      24$ the parameters to the routine are:
      25
      26$ iter:    indicates that we are opening an iterator
      27$ skip:    indicates that we are to skip the current token
      28
      29
      30      nameset opntoks;  $ nameset used to save tokens for openers
      31
      32          +*  save_lim     =  05  **  $ tokens saved/opener
      33          +*  open_lim     =  20  **  $ maximum openers
      34          +*  opntoks_lim  =  (save_lim * open_lim)  **  $ opntoks limit
      35
      36          size open_count(ps);  $ number of openers
      37          data open_count = 0;
      38
      39          +*  is_iter(p)  =  .f. p, 1, itervect  **
      40          size itervect(open_lim);
      41
      42          size opntoks(ps);   $ array of tokens
      43          dims opntoks(opntoks_lim);
      44
      45          size opntoksp(ps);   $ pointer to last saved token
      46          data opntoksp = 0;
      47
      48      end nameset;
      49
      50      size iter(1),  $ indicates opening iterator
      51           skip(1);  $ indicates skipping current token
      52
smfb 146      size tok(ps);           $ last token read
smfb 147      size temp(ps);          $ saved value of 'tok_out'
smfb 148      size j(ps);             $ loop index
      55
      56      size gettok(ps);   $ scanner function
      57
      58      access backup;
      59
      60
      61$ increment open_count and set is_iter
      62
      63      countup(open_count, opntoks_lim, 'openers');
      64      is_iter(open_count) = iter;
      65
      66      temp = tok_out;  $ save place in token buffer
      67
      68      if ^ skip then  $ save current token
      69          countup(opntoksp, opntoks_lim, 'opntoks');
      70          opntoks(opntoksp) = tok_buff(tok_out);
      71      end if;
      72
      73$ save remaining tokens
      74      do j = 1 to save_lim - 1 + skip;
      75          countup(opntoksp, opntoks_lim, 'opntoks');
      76
smfb 149          tok = tok_buff(tok_out);
smfb 150
smfb 151          if tok = sym_semi ! tok = sym_then !
smfb 152                  tok = sym_rp ! tok = sym_do then
smfb 153              $ note that since we do not consume a new token from the
smfb 154              $ input, 'tok_buff(tok_out)' and 'tok' will not change,
smfb 155              $ and this loop indeed will set all remaining entries of
smfb 156              $ 'opntoks' to zero.
smfb 157              opntoks(opntoksp) = 0;
      81          else
      82              opntoks(opntoksp) = gettok(0);
      83          end if;
      84      end do;
      85
      86      tok_out = temp;  $ reset token buffer
      87
      88
      89      end subr opentoks;
       1 .=member endtoks
       2      subr endtoks;
       3
       4$ this routine is called after seeing the keyword 'end'. we compare
       5$ the tokens which follow it with those of the most recent opener.
       6
       7$ on exit the token buffer is positioned so that the next token
       8$ will be the semicolon.
       9
      10
      11      size toks(ps);          $ array of tokens after '.end'
      12      dims toks(save_lim);
      13
      14      size toksp(ps),         $ pointer to last entry in toks
      15           tok(ps),           $ current token
      16           org(ps),           $ origin in opntoks
      17           lev(ps),           $ level of enders
      18           temp1(ps),         $ entry value of tok_out
      19           temp2(ps),         $ temporary used for swap
      20           i(ps),             $ loop index
      21           j(ps);             $ loop index
      22
      23      size gettok(ps);        $ scanner routine
      24
      25      access backup, opntoks, parsens;
      26
      27
      28      temp1 = tok_out;        $ save place in token buffer
      29
      30      toksp = 0;              $ collect tokens to next semicolon
      31      while 1;
smfb 158          tok = gettok(0); if (eof_flag) call eofr;
smfb 159          if (tok = sym_semi) quit;
smfb 160          if tok = sym_then ! tok = sym_rp ! tok = sym_do then
smfb 161              until tok = sym_semi;
smfb 162                  tok = gettok(0); if (eof_flag) call eofr;
smfb 163              end until;
smfb 164              quit while;
smfb 165          end if;
      36
      37          if toksp < save_lim then $ save token
      38              toksp = toksp + 1;
      39              toks(toksp) = tok;
      40          end if;
      41      end while;
      42
      43      tok_out = tok_out - 1;  $ return semicolon
      44      if (tok_out = 0) tok_out = tok_lim;
      45
      46      if toksp = 0 then       $ no tokens,
      47          call poptoks;       $     reset opntoksp, open_count
      48          return;             $     and return.
      49      end if;
      50
      51      $ iterate over the openers, looking for a match.
      52
      53      lev = 0;                $ nesting level
      54      do i = open_count to 1 by -1;
      55          lev = lev + 1;
      56          org = (i-1) * save_lim;  $ origin in opntoks
      57
      58          do j = 1 to toksp;  $ compare tokens
      59              if (toks(j) ^= opntoks(org+j)) cont do i;
      60          end do;
      61
      62          go to found;
      63      end do;
      64
      65      temp2   = tok_out;
      66      tok_out = temp1;
      67
      68      call ermsg(15, 0);
      69
      70      tok_out = temp2;
      71      call poptoks;
      72
      73      return;
      74
      75
      76/found/
      77
      78      call poptoks;           $ reset opntoksp, open_count
      79
      80      if (lev = 1) return;    $ found correct match
      81
      82$ at this point we found a match, but are missing one or more
      83$ -.end-s.  we recover by pretending we have not yet seen the
      84$ current -.end-.
      85
      86      tok_out = temp1;
      87
      88      call ermsg(16, 0);
      89
      90      tok_out = tok_out - 1;
      91      if (tok_out = 0) tok_out = tok_lim;
      92
      93      parsep = parseerrloc;
      94
      95      return;
      96
      97
      98      end subr endtoks;
       1 .=member poptoks
       2      subr poptoks;
       3
       4$ this routine is called at the end of a control statement, after we
       5$ have made any necessary checks for matching tokens. it pops
       6$ opntoks and resets open_count.
       7
       8
       9      access opntoks;
      10
      11
      12      opntoksp = opntoksp - save_lim;
      13      open_count = open_count - 1;
      14
      15
      16      end subr poptoks;
       1 .=member chktoks
       2      subr checktoks(dft);
       3
       4$ this routine compares the tokens after the keywords 'cont' and
       5$ 'quit' to find out which loop they refer to.
       6
       7$ we write out a counter to indicate which loop to cont(quit).
       8$ this is done as follows:
       9
      10$ 1. if the keyword cont(quit) is followed by a semicolon, we
      11$    write out a default, given by the parameter 'dft'.
      12
      13$ 2. otherwise we search opntoks starting with the most recent
      14$    entry until we find one which matches, keeping a counter
      15$    of the number of loop entries we look at, then use this
      16$    counter.
      17
      18$ on exit the token buffer is positioned so that the next token
      19$ will be the semicolon.
      20
      21
      22      size dft(ps);  $ default counter value
      23
      24      size toks(ps);  $ array of tokens after 'cont'
      25      dims toks(save_lim);
      26
      27      size toksp(ps), $ pointer to last entry in toks
      28           tok(ps),  $ current token
      29           org(ps),     $ origin in opntoks
      30           lev(ps),   $ level of loop nesting
      31           i(ps),  $ loop index
      32           j(ps);     $ loop index
      33
      34      size gettok(ps);   $ scanner routine
      35
      36      access opntoks;
      37
      38
      39$ we begin by collecting tokens up to a semicolon, and putting them
      40$ in the array 'toks'.
      41
      42      toksp = 0;
      43
      44      while 1;
smfb 166          tok = gettok(0); if (eof_flag) call eofr;
smfb 167          if (tok = sym_semi) quit;
smfb 168          if tok = sym_then ! tok = sym_rp ! tok = sym_do then
smfb 169              until tok = sym_semi;
smfb 170                  tok = gettok(0); if (eof_flag) call eofr;
smfb 171              end until;
smfb 172              quit while;
smfb 173          end if;
      49
      50          if toksp < save_lim then $ save token
      51              toksp = toksp + 1;
      52              toks(toksp) = tok;
      53          end if;
      54      end while;
      55
      56$ return semicolon
      57      call back(1, 0);
      58
      59$ if there were no tokens, write out a zero onto the polish string and
      60$ return.
      61
      62      if toksp = 0 then
smfa  87          until 1;
smfa  88              do i = open_count to 1 by -1;
smfa  89                  if (is_iter(i)) quit until 1;
smfa  90              end do;
smfa  91              call ermsg(21, 0);
smfa  92          end until;
      63          putp(dft, pol_count);
      64          return;
      65      end if;
      66
      67$ otherwise iterate over the openers, looking for a match.
      68
      69      lev = 0;  $ nesting level of loops
      70
      71      do i = open_count to 1 by -1;
      72          if (^ is_iter(i)) cont;
      73
      74          lev = lev + 1;
      75          org = (i-1) * save_lim;  $ origin in opntoks
      76
      77          do j = 1 to toksp;  $ compare tokens
      78              if (toks(j) ^= opntoks(org+j)) cont do i;
      79          end do;
      80
      81$ found match. write out count and return.
      82
      83          putp(lev, pol_count);
      84
      85          return;
      86      end do;
      87
      88$ no match found - issue message and write out a zero.
      89
      90      call ermsg(17, 0);
      91
      92      putp(dft, pol_count);
      93
      94
      95      end subr checktoks;
       1 .=member svtab
       2      trace entry;
       3
       4      subr svtab;
       5
       6$ this routine saves the values of mttab, namesp, and symtabp
       7$ so that we can later free the space used by local names.
       8$ of the scope.
       9
      10      nameset svtabns;
      11      +*  sv_lim  =  10  ** $ dimension of sv.
      12
smfb 176 .+r32    size sv(96);
suna  62 .+r36    size sv(72);
smfb 177 .+s66    size sv(60);
      19          dims sv(sv_lim);
      20
      21 .+s66.
      22          +*  sv_symtabp(i)  =  .f. 01, 16, sv(i)  **
      23          +*  sv_namesp(i)   =  .f. 17, 16, sv(i)  **
      24          +*  sv_mtabp(i)    =  .f. 33, 16, sv(i)  **
      25 ..s66
      26
smfb 178 .+r32.
      34          +*  sv_symtabp(i)  =  .f. 01, 32, sv(i)  **
      35          +*  sv_namesp(i)   =  .f. 33, 32, sv(i)  **
      36          +*  sv_mtabp(i)    =  .f. 65, 32, sv(i)  **
smfb 179 ..r32
      43
suna  63 .+r36.
      45          +*  sv_symtabp(i)  =  .f. 01, 18, sv(i)  **
      46          +*  sv_namesp(i)   =  .f. 19, 18, sv(i)  **
      47          +*  sv_mtabp(i)    =  .f. 37, 18, sv(i)  **
suna  64 ..r36
      55
      56
      57          size svp(ps);
      58          data svp = 0;
      59      end nameset;
      60
      61      countup(svp, sv_lim, 'sv');
      62
      63      sv_symtabp(svp) = symtabp;
      64      sv_namesp(svp)  = namesp;
      65      sv_mtabp(svp)   = mtabp;
      66
      68
      69      end subr svtab;
       1 .=member retab
       2      subr retab;
       3
       4$ this routine resets mttabp, namesp, and symtabp to their saved
       5$ values, thus freeing a block of table space.
       6
       7      access svtabns;
       8
       9      size j(ps),    $ loop index
      10           p(ps); $ symtab pointer
      11
      12      symtabp = sv_symtabp(svp);
      13      namesp  = sv_namesp(svp);
      14      mtabp   = sv_mtabp(svp);
      15
      16      svp = svp - 1;
      17
      18$ delete all the freed symtab entries from the clash lists.
      19      do j = 1 to heads_lim;
      20          p = heads(j);
      21
      22          while p > symtabp;
      23              p = link(p);
      24          end while;
      25
      26          heads(j) = p;
      27      end do;
      28
      29      return;
      30
      31      end subr retab;
       1 .=member puttabs
       2      subr puttbs;
       3
       4$ this routine writes out both polish strings.
       5
       6      if (sd_flag) call sdump;  $ dump symbol table
       7
       8      call puttab;            $ write polish string
       9      call putxtab;           $ write xpolish string
      10
      11
      12      end subr puttbs;
       1 .=member puttab
       2      subr puttab;
       3
       4$ this routine writes out the polish string. the polish string has
       5$ a somewhat different external format from its internal one.
       6$ markers and counters are written out exactly as they are stored
       7$ in core howwever names have:
       8
       9$ pol_typ:     pol_name
      10$ pol_val:     number of words in 'names' entry
      11
      12$ followed by the actual names entry.
      13
      14$ puttab may be called while we are saving parser states. in this
      15$ case we write out the part of the string we are not saving, move
      16$ the remaining nodes towards the front of the string and adjust
      17$ the pointers from sstack to the polish string. if we cannot write
      18$ anything out then the string is full, and we abort.
      19
      20      size last(ps),   $ last node we can write
      21           j(ps),         $ loop index
      22           nam(ps),  $ names pointer
      23           words(ps);  $ number of words
      24
      25      access backup;
      26
      27
      28      if (pd_flag) call pdump;
      29
      30$ find last node to write
      31
      32      if sstackp = 0 then
      33          last = polp;
      34
      35      else
      36          last = s_polp(1)-1;
      37          if (last = 0) call overfl('polish');
      38      end if;
      39 .-qp.
      40
      41$ write string
      42      do j = 1 to last;
      43          if pol_typ(j) = pol_name then
      44              nam   = pol_val(j);
      45              words = n_sorg(nam)/ws;
      46
      47              pol_val(j) = words;
      48
      49              write pol_file,
      50                  polish(j), names(nam) to names(nam+words-1);
      51
      52          else
      53              write pol_file, polish(j);
      54          end if;
      55      end do;
      56
      57$ move all remaining nodes to front of string then adjust sstack
      58      do j = last+1 to polp;
      59          polish(j-last) = polish(j);
      60      end do;
      61
      62      do j = 1 to sstackp;
      63          s_polp(j) = s_polp(j) - last;
      64      end do;
      65
      66 ..qp
      67      polp = polp - last;     $ reset polish pointer
      68
      69
      70      end subr puttab;
      71
      72      notrace entry;
      73
       1 .=member putxtab
       2      subr putxtab;
       3
       4$ this routine writes out the xpolish string. the xpolish string has
       5$ a somewhat different external format from its internal one.
       6$ markers and counters are written out exactly as they are stored
       7$ in core howwever names have:
       8
       9$ xpol_typ:     pol_name
      10$ xpol_val:     number of words in 'names' entry
      11
      12$ followed by the actual names entry.
      13
      14$ putxtab may be called while we are saving parser states. in this
      15$ case we write out the part of the string we are not saving, move
      16$ the remaining nodes towards the front of the string and adjust
      17$ the pointers from sstack to the xpolish string. if we cannot write
      18$ anything out then the string is full, and we abort.
      19
      20      size last(ps),   $ last node we can write
      21           j(ps),         $ loop index
      22           nam(ps),  $ names pointer
      23           words(ps);  $ number of words
      24
      25      access backup;
      26
      27
      28      if (pd_flag) call xpdump;
      29
      30$ find last node to write
      31
      32      if sstackp = 0 then
      33          last = xpolp;
      34
      35      else
      36          last = s_xpolp(1)-1;
      37          if (last = 0) call overfl('xpolish');
      38      end if;
      39
      40 .-qp.
      41$ write string
      42      do j = 1 to last;
      43          if xpol_typ(j) = pol_name then
      44              nam   = xpol_val(j);
      45              words = n_sorg(nam)/ws;
      46
      47              xpol_val(j) = words;
      48
      49              write xpol_file,
      50                  xpolish(j), names(nam) to names(nam+words-1);
      51
      52          else
      53              write xpol_file, xpolish(j);
      54          end if;
      55      end do;
      56
      57$ move all remaining nodes to front of string then adjust sstack
      58      do j = last+1 to xpolp;
      59          xpolish(j-last) = xpolish(j);
      60      end do;
      61
      62 ..qp
      63      do j = 1 to sstackp;
      64          s_xpolp(j) = s_xpolp(j) - last;
      65      end do;
      66
      67      xpolp = xpolp - last;   $ reset aux. polish pointer
      68
      69
      70      end subr putxtab;
      71
      72      notrace entry;
      73
       1 .=member symsds
       2      fnct symsds(p);
       3
       4$ this routine returns the name of a symbol table entry as a self
       5$ defining string.
       6
       7
       8      size p(ps);   $ symbol table pointer
       9
      10      size symsds(sds_sz),
      11           namesds(sds_sz); $ gets string from names ptr
      12
      13
      14      if p = 0 then
      15          symsds = '';
      16      else
      17          symsds = namesds(name(p));
      18      end if;
      19
      20
      21      end fnct symsds;
       1 .=member namesds
       2      fnct namesds(nam);
       3
       4$ this routine converts a names entry to an sds string.
       5
       6      size nam(ps);  $ pointer to names entry
       7
       8      size namesds(sds_sz);
       9
      10      size j(ps),  $ loop index
      11           words(ps);  $ number of words in names entry
      12
      13      if nam = 0 then  $ missing names entry
      14          namesds = '';
      15          return;
      16      end if;
      17
      18      words = n_sorg(nam)/ws;
      19
      20      do j = 0 to words-1;
      21          .f. 1+j*ws, ws, namesds = names(nam+j);
      22      end do;
      23
      24
      25      end fnct namesds;
       1 .=member ermsg
       2      subr ermsg(n, nam);
       3
       4$ this routine prints lexical error messages. 'n' is the message
       5$ number and 'nam' is an optional symbol table pointer to the
       6$ name which caused the error.
       7
       8
       9      size n(ps),  $ error number
      10           nam(ps);  $ symtab pointer
      11
      12      size string(.sds. 80);  $ message text
      13
      14
smfa  93      go to case(n) in 1 to 21;
      16
      17      +*  et(n, msg) =
      18          /case(n)/   string = msg;  go to esac;
      19          **
      20
      21      et(01, 'macro argument list to begin with -(-');
      22      et(02, 'to have proper number of arguments');
      23      et(03, 'to be valid macro name');
      24      et(04, 'to be defined only once');
      25      et(05, '-(- in macro parameter list');
      26      et(06, 'to appear only once in macro parameter list');
      27      et(07, 'only one -;- in macro parameter list');
      28      et(08, '-,- in macro parameter list');
      29      et(09, '-;- after -endm-');
      30      et(10, '-endm-. macro exceeds maximum length');
      31      et(11, 'macro not to occur within itself');
      32      et(12, 'to be a valid macro name');
      33      et(13, '-,- in macro list');
      34      et(14, 'valid starting character for token');
      35      et(15, 'matching tokens after -end-.')
      36      et(16, 'matching tokens after -end-; attempt to recover ' .cc.
      37             'by inserting missing -end-(s).')
      38      et(17, 'matching tokens after -quit- or -cont-');
      39      et(18, 'token to be less than 128 characters');
      40      et(19, 'end of file after last program member');
      41      et(20, '= after +: or -:.');
smfa  94      et(21, 'open loop to -continue- or -quit-')
      42
      43
      44/esac/
      45
      46      call put_err(n, nam, string);
      47
      48
      49      macdrop(et)
      50
      51      end subr ermsg;
       1 .=member eofr
       2      subr eofr;
       3
       4$ this routine is called when the end of the input file is
       5$ encounterd during a macro definition, etc.
       6
       7$ we print an error message and abort
       8
       9      call put_card;          $ print current line
      10      put, skip;              $ skip to next line
      11      call contlpr(27, yes);  $ start to echo to the terminal
      12 .+s10    put, '?';           $ emit s10 error message marker
      13 .+s20    put, '?';           $ emit s10 error message marker
      14      put,                    $ print message
      15          column(5),
      16          '*** compilation terminated by unexpected end-of-file ***',
      17          skip;
      18      call contlpr(27, no);   $ stop to echo to the terminal
      19
      20      call trcbak;            $ print current token stream
      21
      22      call prstrm(yes);
      23
      24      end subr eofr;
       1 .=member ermet
       2      subr ermet(n);
       3
       4$ this rouine processes syntactic errors. it prints an error message
       5$ then adjusts the parser in an attempt to recover from the error.
       6
       7$ the routine begins with a 'case' statement which maps the
       8$ error number into a message and a recovery mode. at the end of
       9$ the 'case' statement we print the message and perform the
      10$ appropriate recovery actions.
      11
      12$ there are 4  error recovery modes:
      13
      14$ 1. standard errors
      15
      16$    here we simply skip to the next semicolon and branch to
      17$    the grammar's  production.
      18
      19$ 2. errors in expressions
      20
      21$   these are treated like standard errors, except that we stop
      22$   when we see one of ';', ')', ']', '\', 'then', or 'end'.
      23
      24$ 3. errors in declarations.
      25
      26$    these generally occor in the context
      27
      28$ (1)        =     
      29$ (2)        =   
      30
      31$    when we fail to recognize a declaration we think we have
      32$    found an entire , return to line (1), and look
      33$    for a . if we don't find a  we advance the token
      34$    file to the next declaration keyword and backup the
      35$    parser to search for a .
      36
      37$ 4. special errors
      38
      39$    these are errors which are handled by separate error
      40$    recovery routines, so we simply return.
      41
      42 .=zzyorg z
      43
      44      defc(rec_std)
      45      defc(rec_nst)
      46      defc(rec_end)
      47      defc(rec_exp)
      48      defc(rec_dcl)
      49      defc(rec_spc)
      50
      51
      52      size n(ps);  $ error number
      53
      54      size string(.sds. 80),  $ message text
      55           mode(ps),  $ recovery mode
      56           tok(ps);  $ next token
      57
      58$ the array 'enders' gives all tokens which can end an expression.
      59
      60      +*  enders_lim  =  09  **  $ number of enders
      61
      62      size init(1);  $ initilization flag
      63      data init = no;
      64
      65
      66      size enders(.sds. 5);
      67      dims enders(enders_lim);
      68
      69      size j(ps),         $ loop index
      70           str(sds_sz);   $ next token as string
      71
      72      data enders =
      73           ')', '>>', '/)', ',', ';', 'then', 'elseif', 'else', 'end';
      74
      75      +* okey_lim = 11 **
      76      size okeywds(.sds. 9);
      77      dims okeywds(okey_lim);
      78      data okeywds =  'procedure',  'proc',  'operator', 'op',
      79                      'case',       'else',  'elseif',
      80                      'end',        '(',     'loop',     'if';
      81
      82
      83      size symsds(sds_sz),  $ returns name of token
      84           hashlit(ps),  $ hashes literals
      85           gettok(ps);   $ scanner interface
      86
      87      access parsens,
      88          opntoks,
      89             backup;
      90
      91
      92      if ^ init then  $ initialize tables
      93          init = yes;
      94
      95          do j = 1 to enders_lim;
      96              enders(j) = hashlit(enders(j));
      97          end do;
      98          do j = 1 to okey_lim;
      99              okeywds(j) = hashlit(okeywds(j));
     100          end do;
     101      end if;
     102
     103      go to case(n) in 0 to 98;
     104
     105      +*  et(n, m, str) =
     106          /case(n)/
     107              mode = m;
     108              string = str;
     109              go to esac;
     110          **
     111
     112      et(00, rec_std, 'valid error message')
     113      et(01, rec_std, 'semicolon')
     114      et(02, rec_std, 'left parenthesis')
     115      et(03, rec_std, 'right parenthesis')
     116      et(04, rec_std, 'left set brace')
     117      et(05, rec_std, 'right set brace')
     118      et(06, rec_std, 'left tuple bracket')
     119      et(07, rec_std, 'right tuple bracket')
     120      et(08, rec_std, 'colon')
     121      et(09, rec_std, 'assignment operator')
     122      et(10, rec_std, 'dash after directory name')
     123      et(11, rec_std, 'directory name in directory statement')
     124      et(12, rec_std, 'directory or program name in program statement')
     125      et(13, rec_std, 'program name in program statement')
     126      et(14, rec_std, 'library name in library statement')
     127      et(15, rec_std, 'directory name in module statement')
     128      et(16, rec_std, 'module name in module statement')
     129      et(17, rec_std, 'main program description in directory')
     130      et(18, rec_std, 'routine definition')
     131      et(19, rec_std, 'namelist after access right')
     132      et(20, rec_std, 'valid variable number of arguments option')
     133      et(21, rec_std, 'procedure description')
     134      et(22, rec_std, 'directory name in main program description')
     135      et(23, rec_std, 'program name in program description')
     136      et(24, rec_std, 'directory name in module description')
     137      et(25, rec_std, 'module name in module description')
     138      et(26, rec_nst, 'main program.')
     139      et(27, rec_std, 'name in declaration')
     140      et(28, rec_std, 'constant right-hand side in declaration')
     141      et(29, rec_std, 'keyword -back-')
     142      et(30, rec_std, 'mode descriptor')
     143      et(31, rec_std, 'mode name')
     144      et(32, rec_std, '-base- to follow -plex-')
     145      et(33, rec_std, 'list of base names')
     146      et(34, rec_std, 'mode descriptor after base type')
     147      et(35, rec_std, 'valid range definition for integer mode')
     148      et(36, rec_std, 'base name after -elmt-')
     149      et(37, rec_std, 'mode descriptor for tuple range')
     150      et(38, rec_std, 'constant length for homogeneous tuple')
     151      et(39, rec_std, 'mode descriptor for set elements')
     152      et(40, rec_std, 'mode descriptor for multi-valued map range')
     153      et(41, rec_std, 'mode descriptor for map domain elements')
     154      et(42, rec_std, 'procedure name')
     155      et(43, rec_std, 'operator name')
     156      et(44, rec_std, 'formal parameter name')
     157      et(45, rec_std, 'statement')
     158      et(46, rec_std, 'boolean expression in assertion')
     159      et(47, rec_std, 'right-hand side')
     160      et(48, rec_std, 'restricted expression after -from-, ...')
     161      et(49, rec_std, 'expression after -case-')
     162      et(50, rec_nst, 'keyword -of-')
     163      et(51, rec_std, 'case tag')
     164      et(52, rec_std, 'constant expression after -arb- in case tag')
     165      et(53, rec_std, 'debug option')
     166      et(54, rec_std, 'label name after -goto-')
     167      et(55, rec_std, 'boolean expression after -if-')
     168      et(56, rec_nst, 'keyword - then')
     169      et(57, rec_std, 'boolean expression after -elseif-')
     170      et(58, rec_nst, 'loop iterator')
     171      et(59, rec_nst, 'keyword -do- or -)-')
smfb 180      et(60, rec_std, 'expression or semicolon after -return-')
     173      et(61, rec_std, 'trace option')
     174      et(62, rec_std, 'expression after -yield-')
     175      et(63, rec_std, 'keyword -end-')
     176      et(64, rec_exp, 'expression after assignment operator')
     177      et(65, rec_exp, 'valid expression after -from-, ...')
     178      et(66, rec_exp, 'factor after compound operator')
     179      et(67, rec_exp, 'term after assigning binary operator')
     180      et(68, rec_exp, 'term after binary operator')
     181      et(69, rec_exp, 'iterator list')
     182      et(70, rec_exp, 'constraint after iterator list')
     183      et(71, rec_exp, 'term after unary operator')
     184      et(72, rec_exp, 'boolean expression after keyword -case-')
     185      et(73, rec_exp, 'keyword -of-')
     186      et(74, rec_exp, 'case tag')
     187      et(75, rec_exp, 'keyword -else-')
     188      et(76, rec_exp, 'expression after -else-')
     189      et(77, rec_exp, 'expression after case tag')
     190      et(78, rec_exp, 'boolean expression after keyword -if-')
     191      et(79, rec_exp, 'keyword -then-')
     192      et(80, rec_exp, 'expression after keyword -then-')
     193      et(81, rec_exp, 'boolean expression after keyword -elseif-')
     194      et(82, rec_exp, 'expression')
     195      et(83, rec_exp, 'left-hand side or dash')
     196      et(84, rec_exp, 'expression as index or routine parameter')
     197      et(85, rec_std, 'iterator')
     198      et(86, rec_std, 'boolean expression after keyword -while-')
     199      et(87, rec_std, 'boolean expression after keyword -where-')
     200      et(88, rec_std, 'boolean expression after keyword -until-')
     201      et(89, rec_std, 'name')
     202      et(90, rec_std, 'valid block structure')
     203      et(91, rec_std, 'valid statement')
     204      et(92, rec_nst, 'valid procedure definition.')
     205      et(93, rec_std, 'valid data structure representation statement')
     206      et(94, rec_spc, 'colon in assignment')
     207      et(95, rec_exp, '-/- after compound operator')
     208      et(96, rec_std, 'operator name')
     209      et(97, rec_std, 'integer or real denotation')
     210      et(98, rec_end, 'keyword -end-' )
     211
     212
     213/esac/
     214
     215      call put_err(n, 0, string);  $ print message
     216
     217      go to rcase(mode) in rec_std to rec_spc;
     218
     219/rcase(rec_std)/      $ standard error
     220
     221$ advance the scanner to the next semicolon and set the parser to
     222$ .
     223
     224      until tok = sym_semi;
     225          tok = gettok(0);
     226          if (eof_flag) call eofr;;
     227      end until;
     228
     229      parsep = parseerrloc;
     230
     231      return;
     232
     233/rcase(rec_nst)/
     234
     235      $ scan to next semicolon, not past -okey- statement.
     236      until tok = sym_semi;
     237          tok = gettok(0);   if (eof_flag) call eofr;
     238
     239          do j = 1 to okey_lim;
     240              if tok = okeywds(j) then
     241                  call back(1,0);   quit until;
     242              end if;
     243          end do;
     244      end until;
     245
     246      $ parser next looks for a statement block
     247      parse_ok = yes;   parsep = parsep + 1;   return;
     248
     249/rcase(rec_end)/
     250
     251      $ error recovery for missing end statement.
     252      $ since the current token might begin a new procedure, must
     253      $ not scan past.
     254      call contlpr(27, yes);  $ start to echo to the terminal
     255      call put_card;
     256      put,column(14), 'closing statment ';
     257      do j = 1 to save_lim;
     258          put: symsds(opntoks(opntoksp-save_lim + j)), a, x(1);
     259      end do;
     260      put, skip;
     261      call contlpr(27, no);   $ stop to echo to the terminal
     262
     263      until tok = sym_semi;
     264          tok = gettok(0);   if (eof_flag) call eofr;
     265          do j = 1 to 4;
     266              if tok = okeywds(j) then
     267                  call back(1, 0);   quit until;
     268              end if;
     269          end do;
     270      end until;
     271
     272      call poptoks;           $ since we are closing an opener
     273      parsep = parseerrloc;
     274      return;
     275
     276/rcase(rec_exp)/     $ error in expression
     277
     278      while 1;
     279          tok = gettok(0);
     280          if (eof_flag) call eofr;
     281
     282          do j = 1 to enders_lim;
     283              if (tok = enders(j)) quit while;
     284          end do;
     285      end while;
     286
     287      tok_out = tok_out-1;  $ return last token
     288      if (tok_out = 0) tok_out = tok_lim;
     289
     290      parsep = parseerrloc;
     291
     292      return;
     293
     294/rcase(rec_dcl)/     $ error in declaration
     295
     296      while 1;    $ advance token file
     297          tok = gettok(0);
     298
     299          if (lex_typ(tok) = l_dkey) quit;
     300          if (eof_flag) call eofr;
     301      end while;
     302
     303      tok_out = tok_out-1;  $ return last token
     304      if (tok_out = 0) tok_out = tok_lim;
     305
     306$ back up parser two  operations.
     307
     308      j = 0;
     309
     310      until j = 2;
     311          parsep = parsep-1;
     312          if (pt_op(parsep) = po_sub) j = j+1;
     313      end until;
     314
     315      putp(p_error, pol_mark);
     316
     317      return;
     318
     319/rcase(rec_spc)/     $ simply return
     320
     321
     322
     323      macdrop(et)
     324
     325      end subr ermet;
       1 .=member puterr
       2      subr put_err(n, nam, str);
       3
       4$ this routine prints error messages. error messages have the
       5$ form:
       6
       7$ *** error n: expect nam str ***
       8
       9$ nam is either zero or a symbol table pointer, while str is a
      10$ string.
      11
      12$ we print a maximum of 1 error message per line of input.
      13
      14      size n(ps),             $ error number
      15           nam(ps),           $ symbol table pointer
      16           str(sds_sz);       $ error message text
      17
      18      size j(ps),             $ loop index
      19           p(ps);             $ pointer into token buffer
      20
      21      size cur_tok(ps),       $ current token
      22           tok_sds(sds_sz),   $ current token as sds
      23           tok_len(ps),       $ length of cur_tok
      24           line_pos(ps),      $ position in current line
      25           mrk_line(sds_sz),  $ underline string
      26           mrk_flag(1);       $ on if tok_out <= p <= tok_in
      27
      28      size err_line(ps);      $ line number of last error
      29      data err_line = 0;
      30
      31      size symsds(sds_sz);    $ returns symbol as sds
      32
      33      access backup,
      34             nstrulex;
      35
      36
      37      if (err_line = line_no) return;
      38      err_line = line_no;
      39
      40      call contlpr(27, yes);  $ start to echo to terminal
      41
      42      call put_card;          $ print last line
      43
      44 .+s10    put, '?';           $ emit standard s10 error character
      45 .+s20    put, '?';           $ emit standard s10 error character
      46
      47      put, column(5), '******** error ': n, i, ': expect ';
      48      if (nam ^= 0) put: symsds(nam), a, x(1);
      49      put: str, a;
      50      if (m_flag) put, column(19+cpc), '*****';
      51      put, skip;
      52
      53      call trcbak;            $ print current token stream
      54
      55      error_count = error_count + 1;
      56
      57      if error_count > pel then
      58          put, skip, '**** parse error limit exceeded ***', skip;
      59          call prstrm(yes);
      60      end if;
      61
      62      call contlpr(27, no);   $ stop to echo to terminal
      63
      64
      65      end subr put_err;
       1 .=member trcbak
       2      subr trcbak;
       3$
       4$ this routine prints the input token trace back.
       5$
       6$ we print the token stream from -tok_out- minus -etok_lim- through
       7$ -tok_in-, if there are -etok_lim- tokens before -tok_out- in the
       8$ buffer.  we underline each token from -tom_out- through -tok_in,
       9$ using an equal sign for reserved, and a minus sign for unre-
      10$ served tokens.
      11$
      12      size cur_tok(ps);       $ current token
      13      size tok_sds(sds_sz);   $ current token as sds
      14      size tok_len(ps);       $ length of cur_tok
      15      size line_pos(ps);      $ position in current line
      16      size mrk_line(sds_sz);  $ underline string
      17      size mrk_flag(1);       $ on if tok_out <= p <= tok_in
      18
      19      size j(ps);             $ loop index
      20      size p(ps);             $ pointer into token buffer
      21
      22      size symsds(sds_sz);    $ returns symbol as sds
      23
      24      access backup;
      25      access nstrulex;
      26
      27
      28      if (tok_out = 0) return;    $ no tokens in buffer
      29
      30      call contlpr(27, yes);  $ start to echo to terminal
      31
      32      p = tok_out;
      33      do j = 1 to etok_lim + 1;
      34          p = p - 1;
      35          if (p = 0) p = tok_lim;
      36
      37          if p = tok_in then  $ less than -etok_lim- tokens in buffer
      38              p = p + 1;   if (p > tok_lim) p = 1;
      39          end if;
      40      end do;
      41
      42      put, column(14), 'parsing: ';   line_pos = 23;
      43      mrk_line = '' .pad. 9;  $ nb. .len. tok_line = 9
      44      mrk_flag = no;
      45
      46      until p = tok_in;
      47          p = p + 1;
      48          if (p > tok_lim) p = 1;
      49
      50          cur_tok = tok_buff(p);
      51          tok_sds = symsds(cur_tok);
      52          tok_len = .len. tok_sds;
      53
      54          if (mrk_flag = yes) & (tok_len = 0) then
      55              tok_sds = '?????';   tok_len = 5;
      56          end if;
      57
      58          if line_pos + tok_len + 1 > 132 then
      59              put, skip, column(14): mrk_line, a, skip, column(14);
      60              line_pos = 14;
      61
      62              mrk_line = '';
      63          end if;
      64
      65          put, ' ': tok_sds, a;   line_pos = line_pos + 1 + tok_len;
      66
      67          if mrk_flag then    $ underline blank
      68              mrk_line = mrk_line .cc. '-';
      69          else
      70              mrk_line = mrk_line .cc. ' ';
      71          end if;
      72
      73          if (p = tok_out) mrk_flag = yes;
      74
      75          do j = 1 to tok_len; $ underline token
      76              if mrk_flag then
      77                  if lex_typ(cur_tok) > l_string !
      78                              lit_val(cur_tok) ^= 0 then
      79                      mrk_line = mrk_line .cc. '='; $ reserved token
      80                  else
      81                      mrk_line = mrk_line .cc. '-'; $ unreserved token
      82                  end if;
      83              else
      84                  mrk_line = mrk_line .cc. ' ';
      85              end if mrk_flag;
      86          end do j;
      87      end until;
      88
      89      put, skip, column(14): mrk_line, a, skip;
      90
      91      call contlpr(27, no);   $ stop to echo to terminal
      92
      93
      94      end subr trcbak;
       1 .=member chkprs
       2      subr chkprs;
       3
       4$ this routine is called when we have parsed the sentence symbol.
       5
       6$ we check whether we are at the end of the input file.  if so, we
       7$ finished parsing, and merely return.  otherwise, some error must
       8$ have caused us to assume an incorrect block structure; we recover
       9$ by restarting the parser with the production 
      10
      11
      12      size tok(ps),           $ next token
      13           j(ps);             $ loop index
      14
      15      size first(1);          $ on if aleady initialized
      16      data first = yes;
      17
      18      size endnames(.sds. 10);  $ 'end' tokens as strings
      19      dims endnames(17);
      20
      21      data endnames =
      22           'procedure', 'proc', 'operator', 'op',
      23           'end', '(', ')', 'do', ',', 'else', 'elseif',
      24           'doing', 'while', 'where', 'step', 'until', 'term';
      25
      26      size endtoks(ps);
      27      dims endtoks(17);
      28
      29      size hashlit(ps),       $ hashes a literal
      30           gettok(ps);        $ returns the next token
      31
      32      access parsens, backup;
      33
      34
      35      if first then           $ initialize endtoks
      36          first = no;
      37
      38          do j = 1 to 17;
      39              endtoks(j) = hashlit(endnames(j));
      40          end do;
      41      end if;
      42
      43      tok = gettok(0);        $ check for end-of-file
      44      if (eof_flag) return;
      45
      46      do j = 1 to 17;
      47          if tok = endtoks(j) then $ found unexpected end, ...
      48          call ermet(91);
      49              tp_flag = yes;  $ terminate after parse
      50                               $ skip to next semicolon
      51              tok = gettok(0); $ check for end-of-file
      52              if (eof_flag) return;
      53
      54              quit do j;
      55          end if tok;
      56      end do j;
      57
      58      tok_out = tok_out - 1;  $ return token
      59      if (tok_out = 0) tok_out = tok_lim;
      60
      61      parsep   = parseerrmploc;
      62      parse_ok = yes;
      63
      64
      65      end subr chkprs;
       1 .=member chkst
       2      subr chkst;
       3
       4$ this routine is called when the parser looks for a 
       5$ and fails to find one. there are two possibilities:
       6
       7$ 1. the next token is 'end', or some other token which can
       8$    normally follow a series of statements.
       9
      10$ 2. otherwise we assume that the next token begins an invalid
      11$    statement, in which case we issue an error message.
      12
      13$ a token can follow a series of statements if either:
      14
      15$ 1. it is a bold name.
      16$ 2. it is in the set 'endtoks', below.
      17
      18      size tok(ps),   $ next token
      19           j(ps);     $ loop index
      20
      21      size init(1);   $ on if aleady initialized
      22      data init = no;
      23
      24      size endnames(.sds. 10);  $ 'end' tokens as strings
      25      dims endnames(17);
      26
      27      data endnames =
      28          '(',
      29           'procedure', 'proc', 'operator', 'op',
      30           'end', ')', 'do', ',', 'else', 'elseif',
      31           'doing', 'while', 'where', 'step', 'until', 'term';
      32
      33      size endtoks(ps);
      34      dims endtoks(16);
      35
      36      size hashlit(ps),   $ hashes a literal
      37           gettok(ps);    $ gets a token
      38
      39      access parsens, backup;
      40
      41      if init = no then     $ initialize endtoks
      42          init = yes;
      43
      44      do j = 1 to 17;
      45              endtoks(j) = hashlit(endnames(j));
      46          end do;
      47      end if;
      48
      49
      50$ see if next token can follow a series of statements.
      51      tok = gettok(0);
      52
      53      do j = 1 to 17;
      54          if (tok = endtoks(j)) go to pass;
      55      end do;
      56
      57/fail/      $ tok can't follow a block
      58
      59      call ermet(91);
      60      parse_ok = yes;
      61
      62      return;
      63
      64/pass/     $ valid token
      65
      66      tok_out = tok_out - 1;   $ return tok
      67      if (tok_out = 0) tok_out = tok_lim;
      68
      69      return;
      70
      71      end subr chkst;
       1 .=member errend
       2      subr errend;
       3
       4$ this routine is called generally when an extra end
       5$ is found in the program.
       6
       7      size savepp(ps);        $ save parsep location
       8      access parsens;
       9
      10
      11      savepp = parsep;
      12      call ermet(92);
      13      parsep = savepp;
      14
      15
      16      end subr errend;
       1 .=member scanend
       2      subr scanend;
       3
       4$ this routine simply scans ahead to the next semicolon after
       5$ an end statement is found.  it is called for error recovery.
       6
       7      size tok(ps);           $ token
       8      size gettok(ps);        $ returns the next token
       9
      10
      11      until tok = sym_semi;
      12          tok = gettok(0);   if (eof_flag) call eofr;
      13      end until;
      14
      15      call back(1, 0);
      16
      17
      18      end subr scanend;
       1 .=member chkbody
       1 .=member chkrepr
       2      subr chkrepr;
       3
       4$ this routine is similar to chkbody, but is called after we
       5$ fail to find a .
       6
       7$ 1. the next token is 'end'
       8$ 2. the next token is the start of an invalid repr.
       9
      10
      11      size tok(ps);   $ next token
      12
      13      size gettok(ps);        $ returns next token
      14
      15      access parsens, backup;
      16
      17
      18      tok = gettok(0);
      19
      20      if tok = sym_end then
      21          tok_out = tok_out - 1;
      22          if (tok_out = 0) tok_out = tok_lim;
      23      else
      24          call ermet(93);
      25          parse_ok = yes;
      26      end if;
      27
      28
      29      end subr chkrepr;
       1 .=member badasn
       2      subr badasn;
       3
       4$ this routine is called after seeing a statement of the form
       5$ "x = ..." where the colon has been left out of the assignment
       6$ symbol.
       7
       8$ we issue an error message then set up the token buffer so that the
       9$ next token seen will be ':='.
      10
      11
      12      access parsens, backup;
      13
      14      call ermet(75);
      15
      16      tok_out = tok_out - 1;
      17      if (tok_out = 0) tok_out = tok_lim;
      18
      19      tok_buff(tok_out) = sym_asn;
      20
      21
      22      end subr badasn;
       1 .=member sdump
       2      subr sdump;
       3 .-qp.
       4
       5$ this routine dumps the symbol table. the dump is formatted
       6$ in columns; every 'lines_lim' lines we print a series of
       7$ column headings.
       8
       9$ we print the lexical types of tokens using the 'synlexmap'
      10$ created by 'syn'.
      11
      12
      13      +*  lines_max  =  20  **
      14
      15      size j(ps),    $ loop indx
      16           str(sds_sz),  $ token name as sds
      17           tp(.sds. 20),  $ lexical type as ads
      18           lines(ps);    $ number of lines since last dump
      19
      20      size init(1);   $ flags first dump
      21      data init = yes;
      22
      23      size ltyps(.sds. 20);  $ array of lexical types
      24      dims ltyps(l_max);
      25
      26      +*  synlexmap(a, b)  =  data ltyps(b) = a;  **
      27
      28 .=include 'synlex'   $ include map from lexical codes to names
      29
      30      size symsds(sds_sz); $ returns name of symbol
      31
      32
      33$ if this is the first call, we must go over ltyps, trimming
      34$ each name to five characters.
      35
      36      if init then
      37          init = no;
      38
      39          do j = l_min to l_max;
      40              if (.len. ltyps(j) > 5) ltyps(j) = .s. 1, 5, ltyps(j);
      41          end do;
      42      end if;
      43
      44      put, skip(2), column(7), 's y m t a b    d u m p', skip(2);
      45      lines = lines_max;   $ to force new header
      46
      47      do j = 1 to symtabp;
      48          lines = lines + 1;
      49
      50          if lines > lines_max then  $ print header
      51              lines = 1;
      52
      53              put, skip(2), column(7),
      54                   'index     name     lxtyp  kyval  ltval',
      55                   '  link  morg  mcode  margs',
      56                   skip, column(7),
      57                   '--------------------------------------',
      58                   '--------------------------',
      59                   skip;
      60          end if;
      61
      62          str = symsds(j);  $ get token name
      63          if (.len. str > 10) .len. str = 10;
      64
      65          if lex_typ(j) = 0 then
      66              tp = '0';
      67          else
      68              tp = ltyps(lex_typ(j));
      69          end if;
      70
      71          put, column(07):  j, i,
      72               column(14):  str, a,
      73               column(26):  tp,  a,
      74               column(33):  key_val(j), i,
      75               column(40):  lit_val(j), i,
      76               column(47):  link(j),    i,
      77               column(54):  morg(j),    i,
      78               column(61):  mcode(j),   i,
      79               column(68):  margs(j),   i,
      80               skip;
      81
      82      end do;
      83
      84      put, skip(2), column(7),  'end symtab dump', skip(2);
      85
      86
      87 ..qp
      88      end subr sdump;
       1 .=member pdump
       2      subr pdump;
       3 .-qp.
       4
       5$ this routine dumps the polish string. we print nodes one after
       6$ another in standard columns. the handling of tabs is driven
       7$ by an array 'postab' which contains the various tabs.
       8
       9
      10      +*  pos_lim  =  4  **  $ maximum nodes/line
      11
      12      size postab(ps);
      13      dims postab(pos_lim);
      14
      15      data postab = 7, 22, 37, 52;
      16
      17      size pos(ps),   $ index into postab
      18           j(ps),     $ loop index
      19           typ(ps),  $ type of current node
      20           val(ps),  $ value of current node
      21           str(sds_sz);  $ token in sds form
      22
      23$ the names of the polish string markers are obtained from the
      24$ output of 'syn'. they are kept in a nameset so that they can
      25$ be accessed by both polish string dump routines.
      26
      27      nameset mark_names;
      28          size mark_name(.sds. 20);
      29          dims mark_name(parseimpmax);
      30
      31          +*  synmarkmap(a, b)  =  data mark_name(a) = b;  **
      32
      33 .=include synmark
      34
      35      end nameset;
      36
      37      size namesds(sds_sz);  $ gives name of token
      38
      39
      40      put, skip(2), column(7), 'p o l i s h    s t r i n g    d u m p',
      41           skip(2);
      42
      43      pos = 0;   $ column position
      44
      45      do j = 1 to polp;
      46          pos = pos + 1;
      47
      48          if pos > pos_lim then  $ end of line
      49              put, skip;
      50              pos = 1;
      51          end if;
      52
      53          put, column(postab(pos));  $ position in proper column
      54
      55          typ = pol_typ(j);
      56          val = pol_val(j);
      57
      58          go to case(typ) in pol_min to pol_max;
      59
      60      /case(pol_name)/
      61
      62          str = namesds(val);   $ get name as sds
      63          if (.len. str > 10) .len. str = 10;
      64
      65          put: str, a;
      66          cont;
      67
      68      /case(pol_count)/
      69
      70          put: val, i;
      71          cont;
      72
      73      /case(pol_mark)/
      74
      75          put: mark_name(val), a;
      76          cont do j;
      77
      78      /case(pol_end)/
      79
      80          put, skip(2), column(7), 'end of polish file', skip;
      81          cont do j;
      82
      83      end do;
      84
      85      put, skip(2), column(7), 'end polish dump', skip;
      86
      87
      88      macdrop(pos_lim)
      89
      90
      91 ..qp
      92      end subr pdump;
       1 .=member xpdump
       2      subr xpdump;
       3 .-qp.
       4
       5$ this routine is similar to pdump, but dumps the auxiliary string.
       6
       7
       8      +*  pos_lim  =  4  **  $ maximum nodes/line
       9
      10      size postab(ps);
      11      dims postab(pos_lim);
      12
      13      data postab = 7, 22, 37, 52;
      14
      15      size pos(ps),   $ index into postab
      16           j(ps),     $ loop index
      17           typ(ps),  $ type of current node
      18           val(ps),  $ value of current node
      19           str(sds_sz);  $ token in sds form
      20
      21      access mark_names;
      22
      23      size namesds(sds_sz);  $ gives name of token
      24
      25
      26      put, skip(2), column(7), 'x p o l    s t r i n g    d u m p',
      27           skip(2);
      28
      29      pos = 0;   $ column position
      30
      31      do j = 1 to xpolp;
      32          pos = pos + 1;
      33
      34          if pos > pos_lim then  $ end of line
      35              put, skip;
      36              pos = 1;
      37          end if;
      38
      39          put, column(postab(pos));  $ position in proper column
      40
      41          typ = xpol_typ(j);
      42          val = xpol_val(j);
      43
      44          go to case(typ) in pol_min to pol_max;
      45
      46      /case(pol_name)/
      47
      48          str = namesds(val);   $ get name as sds
      49          if (.len. str > 10) .len. str = 10;
      50
      51          put: str, a;
      52          cont;
      53
      54      /case(pol_count)/
      55
      56          put: val, i;
      57          cont;
      58
      59      /case(pol_mark)/
      60
      61          put: mark_name(val), a;
      62          cont do j;
      63
      64      /case(pol_end)/
      65
      66          put, skip(2), column(7), 'end of xpolish file', skip;
      67          cont do j;
      68
      69      end do;
      70
      71      put, skip(2), column(7), 'end xpolish dump', skip;
      72
      73
      74      macdrop(pos_lim)
      75
      76
      77 ..qp
      78      end subr xpdump;
       1 .=member odump
       2      subr odump;
       3 .-qp.
       4
       5$ this routine dumps opntoks. we simply print a series of names.
       6
       7
       8      size j(ps);   $ loop index
       9
      10      size symsds(sds_sz);  $ returns token name
      11
      12      access opntoks;
      13
      14
      15      put, skip(2), column(7), 'o p n t o k s    d u m p', skip(2);
      16
      17      do j = 1 to opntoksp;
      18          put, column(7): symsds(opntoks(j)), a, skip;
      19      end do;
      20
      21
      22 ..qp
      23      end subr odump;
       1 .=member overfl
       2      subr overfl(msg);
       3
       4$ this routine is called when a compiler array overflows. we print
       5$ a message and abort.
       6
       7
       8      size msg(.sds. 100);
       9
      10
      11      put ,skip;              $ emit blank line
      12
      13      call contlpr(27, yes);  $ start to echo to terminal
      14      put, '*** compiler table overflow - ': msg, a, ' ***', skip;
      15      call contlpr(27, no);   $ stop to echo to terminal
      16
      17      put, skip;
      18
      19      call prstrm(yes);
      20
      21
      22      end subr overfl;
       1 .=member usratp
       2      subr usratp;
       3
       4$ this routine is called if the system detects a fatal error.
       5
       6      put ,skip(2) ,'*** fatal error detected by system ***' ,skip(2);
       7
       8      if (^ et_flag) return;
       9
      10      call sdump;
      11      call pdump;
      12      call xpdump;
      13      call odump;
      14
      15
      16      end subr usratp;
       1 .=member prstrm
       2      subr prstrm(abnormal);
       3
       4$ this is the main termination routine. 'abnormal' is true for
       5$ abnormal termination.
       6
       7
       8      size abnormal(1);
       9
      10      size tok(ps);  $ next token on input file
      11
      12$ the following nameset is used to pass the number of lines in the
      13$ source to the overlay executive so that it can compute statistics.
      14
      15      nameset lexcard;
      16          size line_tot(ps);
      17      end nameset;
      18
      19
sunb  39      if lcs_flag then  $ print statistics
sunb  40          put ,skip;  $ emit blank line
      21
sunb  41          if error_count = 0 then
sunb  42              put, 'no errors were detected.', skip;
sunb  43          else
sunb  44              put, 'number of errors detected = ': error_count, i, skip;
sunb  45          end if;
sunb  46      end if;
      27
      28      if abnormal then        $ abort
sunb  47          if (lcs_flag) put ,skip ,'abnormal termination.' ,skip;
      30
      31          call ltlfin(1, 0);
      32
      33      elseif tp_flag then     $ terminate
sunb  48          if (lcs_flag) put ,skip ,'compilation terminated.' ,skip;
      35
      36          call ltlfin(0, 0);
      37
      38      else
sunb  49          if (lcs_flag) put ,skip ,'normal termination.' ,skip;
      40
      41          $ write end-of-file markers
      42          putp(0, pol_end);   putxp(0, pol_end);
      43 .-qp     call puttbs;        $ write remainder of tables
      44
smfa  95 .+sq1.
      46          if (slen ssm_title) then
      47              putbhdr(bt_tuple, 1)
      48              putbhdr(bt_tuple, 1)
      49              putbhdr(bt_map,   1)
      50              file ssm_file access = release;
      51          end if;
      52 ..sq1
      53
      54          file pol_file  access = release;  $ close all scratch files
      55          file xpol_file access = release;
      56          file syn_file  access = release;
      57
      58          line_tot = line_no;  $ pass to overlay exec
      59
      60 .-qp     call ltlterm(1, 0);
      61 .+qp     call ltlfin (0, 0);
      62      end if;
      63
      64
      65      end subr prstrm;
« October 2024 »
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: